!***************************************************************************************** !> ! COMPUTATION OF SPECIAL FUNCTIONS ! ! Shanjie Zhang and Jianming Jin ! ! Copyrighted but permission granted to use code in programs. ! Buy their book "Computation of Special Functions", 1996, John Wiley & Sons, Inc. ! ! Scipy changes: ! - Compiled into a single source file and changed REAL To DBLE throughout. ! - Changed according to ERRATA. ! - Changed GAMMA to GAMMA2 and PSI to PSI_SPEC to avoid potential conflicts. ! - Made functions return sf_error codes in ISFER variables instead ! of printing warnings. The codes are ! - SF_ERROR_OK = 0: no error ! - SF_ERROR_SINGULAR = 1: singularity encountered ! - SF_ERROR_UNDERFLOW = 2: floating point underflow ! - SF_ERROR_OVERFLOW = 3: floating point overflow ! - SF_ERROR_SLOW = 4: too many iterations required ! - SF_ERROR_LOSS = 5: loss of precision ! - SF_ERROR_NO_RESULT = 6: no result obtained ! - SF_ERROR_DOMAIN = 7: out of domain ! - SF_ERROR_ARG = 8: invalid input parameter ! - SF_ERROR_OTHER = 9: unclassified error module specfun_module use iso_fortran_env, only: wp => real64 implicit none real(wp),parameter,private :: pi = acos(-1.0_wp) real(wp),parameter,private :: sqrtpi = sqrt(pi) real(wp),parameter,private :: halfpi = 0.5_wp*pi contains !***************************************************************************************** ! JW: should probably remove these two... real(wp) function dnan() dnan = 0.0_wp dnan = 0.0_wp/dnan end function dnan real(wp) function dinf() dinf = 1.0e300_wp dinf = dinf*dinf end function dinf !***************************************************************************************** !> ! Compute complex parabolic cylinder function `Dn(z)` for small argument subroutine cpdsa(n,z,Cdn) integer,intent(in) :: n !! Order of D(z) (n = 0,-1,-2,...) complex(wp),intent(in) :: z !! complex argument of D(z) complex(wp),intent(out) :: Cdn !! Dn(z) complex(wp) :: ca0 , cb0 , cdw , cr real(wp) :: g0 , g1 , ga0 , gm , pd , va0 , vm , vt , xn integer :: m real(wp),parameter :: eps = 1.0e-15_wp real(wp),parameter :: sq2 = sqrt(2.0_wp) ca0 = exp(-0.25_wp*z*z) va0 = 0.5_wp*(1.0_wp-n) if ( n==0 ) then Cdn = ca0 elseif ( abs(z)==0.0_wp ) then if ( va0<=0.0_wp .and. va0==int(va0) ) then Cdn = 0.0_wp else call gaih(va0,ga0) pd = sqrtpi/(2.0_wp**(-0.5_wp*n)*ga0) Cdn = cmplx(pd,0.0_wp,wp) endif else xn = -n call gaih(xn,g1) cb0 = 2.0_wp**(-0.5_wp*n-1.0_wp)*ca0/g1 vt = -0.5_wp*n call gaih(vt,g0) Cdn = cmplx(g0,0.0_wp,wp) cr = (1.0_wp,0.0_wp) do m = 1 , 250 vm = 0.5_wp*(m-n) call gaih(vm,gm) cr = -cr*sq2*z/m cdw = gm*cr Cdn = Cdn + cdw if ( abs(cdw)<abs(Cdn)*eps ) exit enddo Cdn = cb0*Cdn endif end subroutine cpdsa !***************************************************************************************** !> ! Compute complex Fresnel Integral S(z) and S'(z) subroutine cfs(z,Zf,Zd) complex(wp),intent(in) :: z !! Argument of S(z) complex(wp),intent(out) :: Zf !! S(z) complex(wp),intent(out) :: Zd !! S'(z) complex(wp) :: cf , cf0 , cf1 , cg , cr , d , s , z0 , zp , zp2 real(wp) :: w0 , wb , wb0 integer :: k , m real(wp),parameter :: eps = 1.0e-14_wp w0 = abs(z) zp = halfpi*z*z zp2 = zp*zp z0 = (0.0_wp,0.0_wp) if ( z==z0 ) then s = z0 elseif ( w0<=2.5_wp ) then s = z*zp/3.0_wp cr = s wb0 = 0.0_wp do k = 1 , 80 cr = -0.5_wp*cr*(4.0_wp*k-1.0_wp)/k/(2.0_wp*k+1.0_wp) & /(4.0_wp*k+3.0_wp)*zp2 s = s + cr wb = abs(s) if ( abs(wb-wb0)<eps .and. k>10 ) exit wb0 = wb enddo elseif ( w0>2.5_wp .and. w0<4.5_wp ) then m = 85 s = z0 cf1 = z0 cf0 = (1.0e-100_wp,0.0_wp) do k = m , 0 , -1 cf = (2.0_wp*k+3.0_wp)*cf0/zp - cf1 if ( k/=int(k/2)*2 ) s = s + cf cf1 = cf0 cf0 = cf enddo s = 2.0_wp/(pi*z)*sin(zp)/cf*s else ! Auxiliary functions f(z) and g(z) can be computed using an ! asymptotic expansion in the right quadrant |arg(z)| <= pi/4, not pi/2 ! as sometimes suggested. Use the symmetry S(z) = -iS(-iz). ! Interestingly, most of the expansion code is the same across ! the quadrants. (The fourth power in Z is the equalizer here.) ! Only one constant has to be adapted. if ( aimag(z)>-real(z,wp) .and. aimag(z)<=real(z,wp) ) then ! right quadrant d = cmplx(0.5_wp,0.0_wp,wp) elseif ( aimag(z)>real(z,wp) .and. aimag(z)>=-real(z,wp) ) then ! upper quadrant d = cmplx(0.0_wp,-0.5_wp,wp) elseif ( aimag(z)<-real(z,wp) .and. aimag(z)>=real(z,wp) ) then ! left quadrant d = cmplx(-0.5_wp,0.0_wp,wp) else ! lower quadrant d = cmplx(0.0_wp,0.5_wp,wp) endif cr = (1.0_wp,0.0_wp) cf = (1.0_wp,0.0_wp) do k = 1 , 20 cr = -0.25_wp*cr*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/zp2 cf = cf + cr enddo cr = (1.0_wp,0.0_wp) cg = (1.0_wp,0.0_wp) do k = 1 , 12 cr = -0.25_wp*cr*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/zp2 cg = cg + cr enddo cg = cg/(pi*z*z) s = d - (cf*cos(zp)+cg*sin(zp))/(pi*z) endif Zf = s Zd = sin(halfpi*z*z) end subroutine cfs !***************************************************************************************** !> ! Compute the associated Legendre functions of the second kind, Qmn(x) and Qmn'(x) subroutine lqmn(Mm,m,n,x,Qm,Qd) real(wp),intent(in) :: x !! Argument of Qmn(x) integer,intent(in) :: m !! Order of Qmn(x) ( m = 0,1,2,… ) integer,intent(in) :: n !! Degree of Qmn(x) ( n = 0,1,2,… ) integer,intent(in) :: mm !! Physical dimension of QM and QD real(wp),intent(out) :: Qm(0:Mm,0:n) !! Qmn(x) real(wp),intent(out) :: Qd(0:Mm,0:n) !! Qmn'(x) integer :: i , j , k , km , ls real(wp) :: q0 , q1 , q10 , qf , qf0 , qf1 , qf2 , xq , xs if ( abs(x)==1.0_wp ) then do i = 0 , m do j = 0 , n Qm(i,j) = 1.0e+300_wp Qd(i,j) = 1.0e+300_wp enddo enddo return endif ls = 1 if ( abs(x)>1.0_wp ) ls = -1 xs = ls*(1.0_wp-x*x) xq = sqrt(xs) q0 = 0.5_wp*log(abs((x+1.0_wp)/(x-1.0_wp))) if ( abs(x)<1.0001_wp ) then Qm(0,0) = q0 Qm(0,1) = x*q0 - 1.0_wp Qm(1,0) = -1.0_wp/xq Qm(1,1) = -ls*xq*(q0+x/(1.0_wp-x*x)) do i = 0 , 1 do j = 2 , n Qm(i,j) = ((2.0_wp*j-1.0_wp)*x*Qm(i,j-1)-(j+i-1.0_wp) & *Qm(i,j-2))/(j-i) enddo enddo do j = 0 , n do i = 2 , m Qm(i,j) = -2.0_wp*(i-1.0_wp)*x/xq*Qm(i-1,j) & - ls*(j+i-1.0_wp)*(j-i+2.0_wp)*Qm(i-2,j) enddo enddo else if ( abs(x)>1.1_wp ) then km = 40 + m + n else km = (40+m+n)*int(-1.0_wp-1.8_wp*log(x-1.0_wp)) endif qf2 = 0.0_wp qf1 = 1.0_wp qf0 = 0.0_wp do k = km , 0 , -1 qf0 = ((2*k+3.0_wp)*x*qf1-(k+2.0_wp)*qf2)/(k+1.0_wp) if ( k<=n ) Qm(0,k) = qf0 qf2 = qf1 qf1 = qf0 enddo do k = 0 , n Qm(0,k) = q0*Qm(0,k)/qf0 enddo qf2 = 0.0_wp qf1 = 1.0_wp do k = km , 0 , -1 qf0 = ((2*k+3.0_wp)*x*qf1-(k+1.0_wp)*qf2)/(k+2.0_wp) if ( k<=n ) Qm(1,k) = qf0 qf2 = qf1 qf1 = qf0 enddo q10 = -1.0_wp/xq do k = 0 , n Qm(1,k) = q10*Qm(1,k)/qf0 enddo do j = 0 , n q0 = Qm(0,j) q1 = Qm(1,j) do i = 0 , m - 2 qf = -2.0_wp*(i+1)*x/xq*q1 + (j-i)*(j+i+1.0_wp)*q0 Qm(i+2,j) = qf q0 = q1 q1 = qf enddo enddo endif Qd(0,0) = ls/xs do j = 1 , n Qd(0,j) = ls*j*(Qm(0,j-1)-x*Qm(0,j))/xs enddo do j = 0 , n do i = 1 , m Qd(i,j) = ls*i*x/xs*Qm(i,j) + (i+j)*(j-i+1.0_wp)/xq*Qm(i-1,j) enddo enddo end subroutine lqmn !***************************************************************************************** !> ! Compute the associated Legendre functions Pmn(z) ! and their derivatives Pmn'(z) for a complex ! argument subroutine clpmn(Mm,m,n,x,y,Ntype,Cpm,Cpd) ! Input : x --- Real part of z ! y --- Imaginary part of z ! m --- Order of Pmn(z), m = 0,1,2,...,n ! n --- Degree of Pmn(z), n = 0,1,2,...,N ! mm --- Physical dimension of CPM and CPD ! ntype --- type of cut, either 2 or 3 ! Output: CPM(m,n) --- Pmn(z) ! CPD(m,n) --- Pmn'(z) complex(wp) Cpd , Cpm , z , zq , zs real(wp) x , y integer i , j , ls , m , Mm , n , Ntype dimension Cpm(0:Mm,0:n) , Cpd(0:Mm,0:n) z = dcmplx(x,y) do i = 0 , n do j = 0 , m Cpm(j,i) = (0.0_wp,0.0_wp) Cpd(j,i) = (0.0_wp,0.0_wp) enddo enddo Cpm(0,0) = (1.0_wp,0.0_wp) if ( n==0 ) return if ( abs(x)==1.0_wp .and. y==0.0_wp ) then do i = 1 , n Cpm(0,i) = x**i Cpd(0,i) = 0.5_wp*i*(i+1)*x**(i+1) enddo do j = 1 , n do i = 1 , m if ( i==1 ) then Cpd(i,j) = dinf() elseif ( i==2 ) then Cpd(i,j) = -0.25d0*(j+2)*(j+1)*j*(j-1)*x**(j+1) endif enddo enddo return endif if ( Ntype==2 ) then ! sqrt(1 - z^2) with branch cut on |x|>1 zs = (1.0_wp-z*z) zq = -sqrt(zs) ls = -1 else ! sqrt(z^2 - 1) with branch cut between [-1, 1] zs = (z*z-1.0_wp) zq = sqrt(zs) if ( x<0d0 ) zq = -zq ls = 1 endif do i = 1 , m ! DLMF 14.7.15 Cpm(i,i) = (2.0_wp*i-1.0_wp)*zq*Cpm(i-1,i-1) enddo do i = 0 , min(m,n-1) ! DLMF 14.10.7 Cpm(i,i+1) = (2.0_wp*i+1.0_wp)*z*Cpm(i,i) enddo do i = 0 , m do j = i + 2 , n ! DLMF 14.10.3 Cpm(i,j) = ((2.0_wp*j-1.0_wp)*z*Cpm(i,j-1)-(i+j-1.0_wp) & & *Cpm(i,j-2))/(j-i) enddo enddo Cpd(0,0) = (0.0_wp,0.0_wp) do j = 1 , n ! DLMF 14.10.5 Cpd(0,j) = ls*j*(z*Cpm(0,j)-Cpm(0,j-1))/zs enddo do i = 1 , m do j = i , n ! derivative of DLMF 14.7.11 & DLMF 14.10.6 for type 3 ! derivative of DLMF 14.7.8 & DLMF 14.10.1 for type 2 Cpd(i,j) = ls*(-i*z*Cpm(i,j)/zs+(j+i)*(j-i+1.0_wp) & & /zq*Cpm(i-1,j)) enddo enddo end !***************************************************************************************** !> ! Compute parabolic cylinder function Vv(x) ! for small argument subroutine vvsa(Va,x,Pv) ! Input: x --- Argument ! va --- Order ! Output: PV --- Vv(x) ! Routine called : GAMMA2 for computing Г(x) real(wp) a0 , ep , eps , fac , g1 , ga0 , gm , gw , & & Pv , r , r1 , sq2 , sv , sv0 , v1 , Va , va0 , & & vb0 , vm real(wp) x integer m eps = 1.0d-15 ep = exp(-0.25_wp*x*x) va0 = 1.0_wp + 0.5_wp*Va if ( x/=0.0 ) then sq2 = sqrt(2.0_wp) a0 = 2.0_wp**(-0.5_wp*Va)*ep/(2.0_wp*pi) sv = sin(-(Va+.5d0)*pi) v1 = -0.5_wp*Va call gamma2(v1,g1) Pv = (sv+1.0_wp)*g1 r = 1.0_wp fac = 1.0_wp do m = 1 , 250 vm = .5d0*(m-Va) call gamma2(vm,gm) r = r*sq2*x/m fac = -fac gw = fac*sv + 1.0_wp r1 = gw*r*gm Pv = Pv + r1 if ( abs(r1/Pv)<eps .and. gw/=0.0 ) exit enddo Pv = a0*Pv elseif ( va0<=0.0 .and. va0==int(va0) .or. Va==0.0 ) then Pv = 0.0_wp else vb0 = -0.5_wp*Va sv0 = sin(va0*pi) call gamma2(va0,ga0) Pv = 2.0_wp**vb0*sv0/ga0 endif end !***************************************************************************************** !> ! Compute the zeros of Bessel functions Jn(x) and ! Jn'(x), and arrange them in the order of their ! magnitudes subroutine jdzo(Nt,n,m,p,Zo) ! SciPy: Changed P from a character array to an integer array. ! Input : NT --- Number of total zeros ( NT ≤ 1200 ) ! Output: ZO(L) --- Value of the L-th zero of Jn(x) ! and Jn'(x) ! N(L) --- n, order of Jn(x) or Jn'(x) associated ! with the L-th zero ! M(L) --- m, serial number of the zeros of Jn(x) ! or Jn'(x) associated with the L-th zero ! ( L is the serial number of all the ! zeros of Jn(x) and Jn'(x) ) ! P(L) --- 0 (TM) or 1 (TE), a code for designating the ! zeros of Jn(x) or Jn'(x). ! In the waveguide applications, the zeros ! of Jn(x) correspond to TM modes and ! those of Jn'(x) correspond to TE modes ! Routine called: BJNDD for computing Jn(x), Jn'(x) and ! Jn''(x) real(wp) bj , dj , fj , x , x0 , x1 , x2 , xm , Zo , zoc integer i , j , k , l , l0 , l1 , l2 , m , m1 , mm , n , n1 , nm ,& & Nt integer p(1400) , p1(70) dimension n(1400) , m(1400) , Zo(0:1400) , n1(70) , m1(70) , & & zoc(0:70) , bj(101) , dj(101) , fj(101) x = 0 zoc(0) = 0 if ( Nt<600 ) then xm = -1.0 + 2.248485*Nt**0.5 - .0159382*Nt + & & 3.208775e-4*Nt**1.5 nm = int(14.5+.05875*Nt) mm = int(.02*Nt) + 6 else xm = 5.0 + 1.445389*Nt**.5 + .01889876*Nt - 2.147763e-4*Nt**1.5 nm = int(27.8+.0327*Nt) mm = int(.01088*Nt) + 10 endif l0 = 0 do i = 1 , nm x1 = .407658 + .4795504*(i-1)**.5 + .983618*(i-1) x2 = 1.99535 + .8333883*(i-1)**.5 + .984584*(i-1) l1 = 0 do j = 1 , mm if ( i/=1 .or. j/=1 ) then x = x1 10 call bjndd(i,x,bj,dj,fj) x0 = x x = x - dj(i)/fj(i) if ( x1>xm ) goto 20 if ( abs(x-x0)>1.0d-10 ) goto 10 endif l1 = l1 + 1 n1(l1) = i - 1 m1(l1) = j if ( i==1 ) m1(l1) = j - 1 p1(l1) = 1 zoc(l1) = x if ( i<=15 ) then x1 = x + 3.057 + .0122*(i-1) + (1.555+.41575*(i-1))/(j+1)& & **2 else x1 = x + 2.918 + .01924*(i-1) + (6.26+.13205*(i-1))/(j+1)& & **2 endif 20 x = x2 40 call bjndd(i,x,bj,dj,fj) x0 = x x = x - bj(i)/dj(i) if ( x<=xm ) then if ( abs(x-x0)>1.0d-10 ) goto 40 l1 = l1 + 1 n1(l1) = i - 1 m1(l1) = j p1(l1) = 0 zoc(l1) = x if ( i<=15 ) then x2 = x + 3.11 + .0138*(i-1) + (.04832+.2804*(i-1)) & & /(j+1)**2 else x2 = x + 3.001 + .0105*(i-1) + (11.52+.48525*(i-1)) & & /(j+3)**2 endif endif enddo l = l0 + l1 l2 = l 50 if ( l0==0 ) then do k = 1 , l Zo(k) = zoc(k) n(k) = n1(k) m(k) = m1(k) p(k) = p1(k) enddo l1 = 0 elseif ( l0/=0 ) then if ( Zo(l0)>=zoc(l1) ) then Zo(l0+l1) = Zo(l0) n(l0+l1) = n(l0) m(l0+l1) = m(l0) p(l0+l1) = p(l0) l0 = l0 - 1 else Zo(l0+l1) = zoc(l1) n(l0+l1) = n1(l1) m(l0+l1) = m1(l1) p(l0+l1) = p1(l1) l1 = l1 - 1 endif endif if ( l1/=0 ) goto 50 l0 = l2 enddo end !***************************************************************************************** !> ! Compute coefficient Bk's for oblate radial ! functions with a small argument subroutine cbk(m,n,c,Cv,Qt,Ck,Bk) real(wp) Bk , c , Ck , Cv , eps , Qt , r1 , s1 , sw , t , & & u , v , w integer i , i1 , ip , j , k , m , n , n2 , nm dimension Bk(200) , Ck(200) , u(200) , v(200) , w(200) eps = 1.0d-14 ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 nm = 25 + int(0.5*(n-m)+c) u(1) = 0.0_wp n2 = nm - 2 do j = 2 , n2 u(j) = c*c enddo do j = 1 , n2 v(j) = (2.0*j-1.0-ip)*(2.0*(j-m)-ip) + m*(m-1.0) - Cv enddo do j = 1 , nm - 1 w(j) = (2.0*j-ip)*(2.0*j+1.0-ip) enddo if ( ip==0 ) then sw = 0.0_wp do k = 0 , n2 - 1 s1 = 0.0_wp i1 = k - m + 1 do i = i1 , nm if ( i>=0 ) then r1 = 1.0_wp do j = 1 , k r1 = r1*(i+m-j)/j enddo s1 = s1 + Ck(i+1)*(2.0*i+m)*r1 if ( abs(s1-sw)<abs(s1)*eps ) exit sw = s1 endif enddo Bk(k+1) = Qt*s1 enddo elseif ( ip==1 ) then sw = 0.0_wp do k = 0 , n2 - 1 s1 = 0.0_wp i1 = k - m + 1 do i = i1 , nm if ( i>=0 ) then r1 = 1.0_wp do j = 1 , k r1 = r1*(i+m-j)/j enddo if ( i>0 ) s1 = s1 + Ck(i)*(2.0*i+m-1)*r1 s1 = s1 - Ck(i+1)*(2.0*i+m)*r1 if ( abs(s1-sw)<abs(s1)*eps ) exit sw = s1 endif enddo Bk(k+1) = Qt*s1 enddo endif w(1) = w(1)/v(1) Bk(1) = Bk(1)/v(1) do k = 2 , n2 t = v(k) - w(k-1)*u(k) w(k) = w(k)/t Bk(k) = (Bk(k)-Bk(k-1)*u(k))/t enddo do k = n2 - 1 , 1 , -1 Bk(k) = Bk(k) - w(k)*Bk(k+1) enddo end !***************************************************************************************** !> ! Compute prolate spheroidal radial function ! of the second kind with a small argument subroutine rmn2sp(m,n,c,x,Cv,Df,Kd,R2f,R2d) real(wp) c , ck1 , ck2 , Cv , Df , dn , eps , ga , gb , & & gc , pd , pm , qd , qm , r1 , r2 , R2d , R2f , & & r3 , r4 real(wp) sd , sd0 , sd1 , sd2 , sdm , sf , spd1 , spd2 , & & spl , su0 , su1 , su2 , sum , sw , x integer ip , j , j1 , j2 , k , Kd , ki , l1 , m , n , nm , nm1 , & & nm2 , nm3 dimension pm(0:251) , pd(0:251) , qm(0:251) , qd(0:251) , dn(200) & & , Df(200) if ( abs(Df(1))<1.0d-280 ) then R2f = 1.0e+300_wp R2d = 1.0e+300_wp return endif eps = 1.0d-14 ip = 1 nm1 = int((n-m)/2) if ( n-m==2*nm1 ) ip = 0 nm = 25 + nm1 + int(c) nm2 = 2*nm + m call kmn(m,n,c,Cv,Kd,Df,dn,ck1,ck2) call lpmns(m,nm2,x,pm,pd) call lqmns(m,nm2,x,qm,qd) su0 = 0.0_wp sw = 0.0_wp do k = 1 , nm j = 2*k - 2 + m + ip su0 = su0 + Df(k)*qm(j) if ( k>nm1 .and. abs(su0-sw)<abs(su0)*eps ) exit sw = su0 enddo sd0 = 0.0_wp do k = 1 , nm j = 2*k - 2 + m + ip sd0 = sd0 + Df(k)*qd(j) if ( k>nm1 .and. abs(sd0-sw)<abs(sd0)*eps ) exit sw = sd0 enddo su1 = 0.0_wp sd1 = 0.0_wp do k = 1 , m j = m - 2*k + ip if ( j<0 ) j = -j - 1 su1 = su1 + dn(k)*qm(j) sd1 = sd1 + dn(k)*qd(j) enddo ga = ((x-1.0_wp)/(x+1.0_wp))**(0.5_wp*m) do k = 1 , m j = m - 2*k + ip if ( j<0 ) then if ( j<0 ) j = -j - 1 r1 = 1.0_wp do j1 = 1 , j r1 = (m+j1)*r1 enddo r2 = 1.0_wp do j2 = 1 , m - j - 2 r2 = j2*r2 enddo r3 = 1.0_wp sf = 1.0_wp do l1 = 1 , j r3 = 0.5_wp*r3*(-j+l1-1.0)*(j+l1)/((m+l1)*l1)*(1.0-x) sf = sf + r3 enddo if ( m-j>=2 ) gb = (m-j-1.0_wp)*r2 if ( m-j<=1 ) gb = 1.0_wp spl = r1*ga*gb*sf su1 = su1 + (-1)**(j+m)*dn(k)*spl spd1 = m/(x*x-1.0_wp)*spl gc = 0.5_wp*j*(j+1.0)/(m+1.0) sd = 1.0_wp r4 = 1.0_wp do l1 = 1 , j - 1 r4 = 0.5_wp*r4*(-j+l1)*(j+l1+1.0)/((m+l1+1.0)*l1)*(1.0-x) sd = sd + r4 enddo spd2 = r1*ga*gb*gc*sd sd1 = sd1 + (-1)**(j+m)*dn(k)*(spd1+spd2) endif enddo su2 = 0.0_wp ki = (2*m+1+ip)/2 nm3 = nm + ki do k = ki , nm3 j = 2*k - 1 - m - ip su2 = su2 + dn(k)*pm(j) if ( j>m .and. abs(su2-sw)<abs(su2)*eps ) exit sw = su2 enddo sd2 = 0.0_wp do k = ki , nm3 j = 2*k - 1 - m - ip sd2 = sd2 + dn(k)*pd(j) if ( j>m .and. abs(sd2-sw)<abs(sd2)*eps ) exit sw = sd2 enddo sum = su0 + su1 + su2 sdm = sd0 + sd1 + sd2 R2f = sum/ck2 R2d = sdm/ck2 end !***************************************************************************************** !> ! Compute Bernoulli number Bn subroutine bernob(n,Bn) ! Input : n --- Serial number ! Output: BN(n) --- Bn real(wp) Bn , r1 , r2 , s , tpi integer k , m , n dimension Bn(0:n) tpi = 6.283185307179586d0 Bn(0) = 1.0_wp Bn(1) = -0.5_wp Bn(2) = 1.0_wp/6.0_wp r1 = (2.0_wp/tpi)**2 do m = 4 , n , 2 r1 = -r1*(m-1)*m/(tpi*tpi) r2 = 1.0_wp do k = 2 , 10000 s = (1.0_wp/k)**m r2 = r2 + s if ( s<1.0d-15 ) exit enddo Bn(m) = r1*r2 enddo end !***************************************************************************************** !> ! Compute Bernoulli number Bn subroutine bernoa(n,Bn) ! Input : n --- Serial number ! Output: BN(n) --- Bn implicit none real(wp) Bn , r , s integer j , k , m , n dimension Bn(0:n) Bn(0) = 1.0_wp Bn(1) = -0.5_wp do m = 2 , n s = -(1.0_wp/(m+1.0_wp)-0.5_wp) do k = 2 , m - 1 r = 1.0_wp do j = 2 , k r = r*(j+m-k)/j enddo s = s - r*Bn(k) enddo Bn(m) = s enddo do m = 3 , n , 2 Bn(m) = 0.0_wp enddo end !***************************************************************************************** !> ! Compute Q*mn(-ic) for oblate radial functions ! with a small argument subroutine qstar(m,n,c,Ck,Ck1,Qs,Qt) real(wp) ap , c , Ck , Ck1 , Qs , qs0 , Qt , r , s , sk integer i , ip , k , l , m , n dimension ap(200) , Ck(200) ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 r = 1.0_wp/Ck(1)**2 ap(1) = r do i = 1 , m s = 0.0_wp do l = 1 , i sk = 0.0_wp do k = 0 , l sk = sk + Ck(k+1)*Ck(l-k+1) enddo s = s + sk*ap(i-l+1) enddo ap(i+1) = -r*s enddo qs0 = ap(m+1) do l = 1 , m r = 1.0_wp do k = 1 , l r = r*(2.0_wp*k+ip)*(2.0_wp*k-1.0_wp+ip)/(2.0_wp*k)**2 enddo qs0 = qs0 + ap(m-l+1)*r enddo Qs = (-1)**ip*Ck1*(Ck1*qs0)/c Qt = -2.0_wp/Ck1*Qs end !***************************************************************************************** !> ! Compute the initial characteristic value of ! Mathieu functions for m ≤ 12 or q ≤ 300 or ! q ≥ m*m subroutine cv0(Kd,m,q,a0) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! Output: A0 --- Characteristic value implicit none real(wp) a0 , q , q2 integer Kd , m q2 = q*q if ( m==0 ) then if ( q<=1.0 ) then a0 = (((.0036392*q2-.0125868)*q2+.0546875)*q2-.5)*q2 elseif ( q<=10.0 ) then a0 = ((3.999267d-3*q-9.638957d-2)*q-.88297)*q + .5542818 else call cvql(Kd,m,q,a0) endif elseif ( m==1 ) then if ( q<=1.0 .and. Kd==2 ) then a0 = (((-6.51e-4*q-.015625)*q-.125)*q+1.0)*q + 1.0 elseif ( q<=1.0 .and. Kd==3 ) then a0 = (((-6.51e-4*q+.015625)*q-.125)*q-1.0)*q + 1.0 elseif ( q<=10.0 .and. Kd==2 ) then a0 = (((-4.94603d-4*q+1.92917d-2)*q-.3089229)*q+1.33372) & & *q + .811752 elseif ( q<=10.0 .and. Kd==3 ) then a0 = ((1.971096d-3*q-5.482465d-2)*q-1.152218)*q + 1.10427 else call cvql(Kd,m,q,a0) endif elseif ( m==2 ) then if ( q<=1.0 .and. Kd==1 ) then a0 = (((-.0036391*q2+.0125888)*q2-.0551939)*q2+.416667) & & *q2 + 4.0 elseif ( q<=1.0 .and. Kd==4 ) then a0 = (.0003617*q2-.0833333)*q2 + 4.0 elseif ( q<=15 .and. Kd==1 ) then a0 = (((3.200972d-4*q-8.667445d-3)*q-1.829032d-4) & & *q+.9919999)*q + 3.3290504 elseif ( q<=10.0 .and. Kd==4 ) then a0 = ((2.38446d-3*q-.08725329)*q-4.732542d-3)*q + 4.00909 else call cvql(Kd,m,q,a0) endif elseif ( m==3 ) then if ( q<=1.0 .and. Kd==2 ) then a0 = ((6.348e-4*q+.015625)*q+.0625)*q2 + 9.0 elseif ( q<=1.0 .and. Kd==3 ) then a0 = ((6.348e-4*q-.015625)*q+.0625)*q2 + 9.0 elseif ( q<=20.0 .and. Kd==2 ) then a0 = (((3.035731d-4*q-1.453021d-2)*q+.19069602)*q-.1039356) & & *q + 8.9449274 elseif ( q<=15.0 .and. Kd==3 ) then a0 = ((9.369364d-5*q-.03569325)*q+.2689874)*q + 8.771735 else call cvql(Kd,m,q,a0) endif elseif ( m==4 ) then if ( q<=1.0 .and. Kd==1 ) then a0 = ((-2.1e-6*q2+5.012e-4)*q2+.0333333)*q2 + 16.0 elseif ( q<=1.0 .and. Kd==4 ) then a0 = ((3.7e-6*q2-3.669e-4)*q2+.0333333)*q2 + 16.0 elseif ( q<=25.0 .and. Kd==1 ) then a0 = (((1.076676d-4*q-7.9684875d-3)*q+.17344854)*q-.5924058)& & *q + 16.620847 elseif ( q<=20.0 .and. Kd==4 ) then a0 = ((-7.08719d-4*q+3.8216144d-3)*q+.1907493)*q + 15.744 else call cvql(Kd,m,q,a0) endif elseif ( m==5 ) then if ( q<=1.0 .and. Kd==2 ) then a0 = ((6.8e-6*q+1.42e-5)*q2+.0208333)*q2 + 25.0 elseif ( q<=1.0 .and. Kd==3 ) then a0 = ((-6.8e-6*q+1.42e-5)*q2+.0208333)*q2 + 25.0 elseif ( q<=35.0 .and. Kd==2 ) then a0 = (((2.238231d-5*q-2.983416d-3)*q+.10706975)*q-.600205) & & *q + 25.93515 elseif ( q<=25.0 .and. Kd==3 ) then a0 = ((-7.425364d-4*q+2.18225d-2)*q+4.16399d-2)*q + 24.897 else call cvql(Kd,m,q,a0) endif elseif ( m==6 ) then if ( q<=1.0 ) then a0 = (.4d-6*q2+.0142857)*q2 + 36.0 elseif ( q<=40.0 .and. Kd==1 ) then a0 = (((-1.66846d-5*q+4.80263d-4)*q+2.53998d-2)*q-.181233) & & *q + 36.423 elseif ( q<=35.0 .and. Kd==4 ) then a0 = ((-4.57146d-4*q+2.16609d-2)*q-2.349616d-2)*q + 35.99251 else call cvql(Kd,m,q,a0) endif elseif ( m==7 ) then if ( q<=10.0 ) then call cvqm(m,q,a0) elseif ( q<=50.0 .and. Kd==2 ) then a0 = (((-1.411114d-5*q+9.730514d-4)*q-3.097887d-3) & & *q+3.533597d-2)*q + 49.0547 elseif ( q<=40.0 .and. Kd==3 ) then a0 = ((-3.043872d-4*q+2.05511d-2)*q-9.16292d-2)*q + 49.19035 else call cvql(Kd,m,q,a0) endif elseif ( m>=8 ) then if ( q<=3.*m ) then call cvqm(m,q,a0) elseif ( q>m*m ) then call cvql(Kd,m,q,a0) elseif ( m==8 .and. Kd==1 ) then a0 = (((8.634308d-6*q-2.100289d-3)*q+.169072)*q-4.64336) & & *q + 109.4211 elseif ( m==8 .and. Kd==4 ) then a0 = ((-6.7842d-5*q+2.2057d-3)*q+.48296)*q + 56.59 elseif ( m==9 .and. Kd==2 ) then a0 = (((2.906435d-6*q-1.019893d-3)*q+.1101965)*q-3.821851) & & *q + 127.6098 elseif ( m==9 .and. Kd==3 ) then a0 = ((-9.577289d-5*q+.01043839)*q+.06588934)*q + 78.0198 elseif ( m==10 .and. Kd==1 ) then a0 = (((5.44927d-7*q-3.926119d-4)*q+.0612099)*q-2.600805) & & *q + 138.1923 elseif ( m==10 .and. Kd==4 ) then a0 = ((-7.660143d-5*q+.01132506)*q-.09746023)*q + 99.29494 elseif ( m==11 .and. Kd==2 ) then a0 = (((-5.67615d-7*q+7.152722d-6)*q+.01920291)*q-1.081583) & & *q + 140.88 elseif ( m==11 .and. Kd==3 ) then a0 = ((-6.310551d-5*q+.0119247)*q-.2681195)*q + 123.667 elseif ( m==12 .and. Kd==1 ) then a0 = (((-2.38351d-7*q-2.90139d-5)*q+.02023088)*q-1.289) & & *q + 171.2723 elseif ( m==12 .and. Kd==4 ) then a0 = (((3.08902d-7*q-1.577869d-4)*q+.0247911)*q-1.05454) & & *q + 161.471 endif endif end !***************************************************************************************** !> ! Compute the characteristic value of Mathieu ! functions for q ≤ m*m subroutine cvqm(m,q,a0) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! Output: A0 --- Initial characteristic value real(wp) a0 , hm1 , hm3 , hm5 , q integer m hm1 = .5*q/(m*m-1.0) hm3 = .25*hm1**3/(m*m-4.0) hm5 = hm1*hm3*q/((m*m-1.0)*(m*m-9.0)) a0 = m*m + q*(hm1+(5.0*m*m+7.0)*hm3+(9.0*m**4+58.0*m*m+29.0)*hm5) end !***************************************************************************************** !> ! Compute the characteristic value of Mathieu ! functions for q ≥ 3m subroutine cvql(Kd,m,q,a0) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! Output: A0 --- Initial characteristic value real(wp) a0 , c1 , cv1 , cv2 , d1 , d2 , d3 , d4 , p1 , & & p2 , q , w , w2 , w3 , w4 , w6 integer Kd , m w = 0.0_wp if ( Kd==1 .or. Kd==2 ) w = 2.0_wp*m + 1.0_wp if ( Kd==3 .or. Kd==4 ) w = 2.0_wp*m - 1.0_wp w2 = w*w w3 = w*w2 w4 = w2*w2 w6 = w2*w4 d1 = 5.0 + 34.0/w2 + 9.0/w4 d2 = (33.0+410.0/w2+405.0/w4)/w d3 = (63.0+1260.0/w2+2943.0/w4+486.0/w6)/w2 d4 = (527.0+15617.0/w2+69001.0/w4+41607.0/w6)/w3 c1 = 128.0 p2 = q/w4 p1 = sqrt(p2) cv1 = -2.0*q + 2.0*w*sqrt(q) - (w2+1.0)/8.0 cv2 = (w+3.0/w) + d1/(32.0*p1) + d2/(8.0*c1*p2) cv2 = cv2 + d3/(64.0*c1*p1*p2) + d4/(16.0*c1*c1*p2*p2) a0 = cv1 - cv2/(c1*p1) end !***************************************************************************************** !> ! Determine the starting point for backward ! recurrence such that the magnitude of ! Jn(x) at that point is about 10^(-MP) integer function msta1(x,Mp) ! Input : x --- Argument of Jn(x) ! MP --- Value of magnitude ! Output: MSTA1 --- Starting point real(wp) a0 , f , f0 , f1 , x integer it , Mp , n0 , n1 , nn a0 = abs(x) n0 = int(1.1_wp*a0) + 1 f0 = envj(n0,a0) - Mp n1 = n0 + 5 f1 = envj(n1,a0) - Mp do it = 1 , 20 nn = n1 - (n1-n0)/(1.0_wp-f0/f1) f = envj(nn,a0) - Mp if ( abs(nn-n1)<1 ) exit n0 = n1 f0 = f1 n1 = nn f1 = f enddo msta1 = nn end !***************************************************************************************** !> ! Determine the starting point for backward ! recurrence such that all Jn(x) has MP ! significant digits integer function msta2(x,n,Mp) ! Input : x --- Argument of Jn(x) ! n --- Order of Jn(x) ! MP --- Significant digit ! Output: MSTA2 --- Starting point real(wp) a0 , ejn , f , f0 , f1 , hmp , obj , x integer it , Mp , n , n0 , n1 , nn a0 = abs(x) hmp = 0.5_wp*Mp ejn = envj(n,a0) if ( ejn<=hmp ) then obj = Mp n0 = int(1.1*a0) + 1 else obj = hmp + ejn n0 = n endif f0 = envj(n0,a0) - obj n1 = n0 + 5 f1 = envj(n1,a0) - obj do it = 1 , 20 nn = n1 - (n1-n0)/(1.0_wp-f0/f1) f = envj(nn,a0) - obj if ( abs(nn-n1)<1 ) exit n0 = n1 f0 = f1 n1 = nn f1 = f enddo msta2 = nn + 10 end !***************************************************************************************** !> ! real(wp) function envj(n,x) implicit none integer n real(wp) x envj = 0.5_wp*log10(6.28d0*n) - n*log10(1.36d0*x/n) end !***************************************************************************************** !> ! Integrate [1-J0(t)]/t with respect to t from 0 ! to x, and Y0(t)/t with respect to t from x to ∞ subroutine ittjyb(x,Ttj,Tty) ! Input : x --- Variable in the limits ( x ≥ 0 ) ! Output: TTJ --- Integration of [1-J0(t)]/t from 0 to x ! TTY --- Integration of Y0(t)/t from x to ∞ real(wp) e0 , el , f0 , g0 , t , t1 , Ttj , Tty , x ,& & x1 , xt el = .5772156649015329d0 if ( x==0.0_wp ) then Ttj = 0.0_wp Tty = -1.0e+300_wp elseif ( x<=4.0_wp ) then x1 = x/4.0_wp t = x1*x1 Ttj = ((((((.35817d-4*t-.639765d-3)*t+.7092535d-2)*t- & & .055544803d0)*t+.296292677d0)*t-.999999326d0) & & *t+1.999999936d0)*t Tty = (((((((-.3546d-5*t+.76217d-4)*t-.1059499d-2)*t+ & & .010787555d0)*t-.07810271d0)*t+.377255736d0) & & *t-1.114084491d0)*t+1.909859297d0)*t e0 = el + log(x/2.0_wp) Tty = pi/6.0_wp + e0/pi*(2.0_wp*Ttj-e0) - Tty elseif ( x<=8.0_wp ) then xt = x + .25d0*pi t1 = 4.0_wp/x t = t1*t1 f0 = (((((.0145369d0*t-.0666297d0)*t+.1341551d0)*t-.1647797d0) & & *t+.1608874d0)*t-.2021547d0)*t + .7977506d0 g0 = ((((((.0160672d0*t-.0759339d0)*t+.1576116d0)*t-.1960154d0)& & *t+.1797457d0)*t-.1702778d0)*t+.3235819d0)*t1 Ttj = (f0*cos(xt)+g0*sin(xt))/(sqrt(x)*x) Ttj = Ttj + el + log(x/2.0_wp) Tty = (f0*sin(xt)-g0*cos(xt))/(sqrt(x)*x) else t = 8.0_wp/x xt = x + .25d0*pi f0 = (((((.18118d-2*t-.91909d-2)*t+.017033d0)*t-.9394d-3) & & *t-.051445d0)*t-.11d-5)*t + .7978846d0 g0 = (((((-.23731d-2*t+.59842d-2)*t+.24437d-2)*t-.0233178d0) & & *t+.595d-4)*t+.1620695d0)*t Ttj = (f0*cos(xt)+g0*sin(xt))/(sqrt(x)*x) & & + el + log(x/2.0_wp) Tty = (f0*sin(xt)-g0*cos(xt))/(sqrt(x)*x) endif end !***************************************************************************************** !> ! Integrate [1-J0(t)]/t with respect to t from 0 ! to x, and Y0(t)/t with respect to t from x to ∞ subroutine ittjya(x,Ttj,Tty) ! Input : x --- Variable in the limits ( x ≥ 0 ) ! Output: TTJ --- Integration of [1-J0(t)]/t from 0 to x ! TTY --- Integration of Y0(t)/t from x to ∞ real(wp) a0 , b1 , bj0 , bj1 , by0 , by1 , e0 , el , g0 , & & g1 , px , qx , r , r0 , r1 , r2 , rs , t , & & Ttj real(wp) Tty , vt , x , xk integer k , l el = .5772156649015329d0 if ( x==0.0_wp ) then Ttj = 0.0_wp Tty = -1.0e+300_wp elseif ( x<=20.0d0 ) then Ttj = 1.0_wp r = 1.0_wp do k = 2 , 100 r = -0.25_wp*r*(k-1.0_wp)/(k*k*k)*x*x Ttj = Ttj + r if ( abs(r)<abs(Ttj)*1.0d-12 ) exit enddo Ttj = Ttj*.125d0*x*x e0 = .5d0*(pi*pi/6.0_wp-el*el) - (0.5_wp*log(x/2.0_wp)+el) & & *log(x/2.0_wp) b1 = el + log(x/2.0_wp) - 1.5d0 rs = 1.0_wp r = -1.0_wp do k = 2 , 100 r = -0.25_wp*r*(k-1.0_wp)/(k*k*k)*x*x rs = rs + 1.0_wp/k r2 = r*(rs+1.0_wp/(2.0_wp*k)-(el+log(x/2.0_wp))) b1 = b1 + r2 if ( abs(r2)<abs(b1)*1.0d-12 ) exit enddo Tty = 2.0_wp/pi*(e0+.125d0*x*x*b1) else a0 = sqrt(2.0_wp/(pi*x)) bj0 = 0.0_wp by0 = 0.0_wp bj1 = 0.0_wp do l = 0 , 1 vt = 4.0_wp*l*l px = 1.0_wp r = 1.0_wp do k = 1 , 14 r = -.0078125d0*r*(vt-(4.0_wp*k-3.0_wp)**2)/(x*k) & & *(vt-(4.0_wp*k-1.0_wp)**2)/((2.0_wp*k-1.0_wp)*x) px = px + r if ( abs(r)<abs(px)*1.0d-12 ) exit enddo qx = 1.0_wp r = 1.0_wp do k = 1 , 14 r = -.0078125d0*r*(vt-(4.0_wp*k-1.0_wp)**2)/(x*k) & & *(vt-(4.0_wp*k+1.0_wp)**2)/(2.0_wp*k+1.0_wp)/x qx = qx + r if ( abs(r)<abs(qx)*1.0d-12 ) exit enddo qx = .125d0*(vt-1.0_wp)/x*qx xk = x - (.25d0+.5d0*l)*pi bj1 = a0*(px*cos(xk)-qx*sin(xk)) by1 = a0*(px*sin(xk)+qx*cos(xk)) if ( l==0 ) then bj0 = bj1 by0 = by1 endif enddo t = 2.0_wp/x g0 = 1.0_wp r0 = 1.0_wp do k = 1 , 10 r0 = -k*k*t*t*r0 g0 = g0 + r0 enddo g1 = 1.0_wp r1 = 1.0_wp do k = 1 , 10 r1 = -k*(k+1.0_wp)*t*t*r1 g1 = g1 + r1 enddo Ttj = 2.0_wp*g1*bj0/(x*x) - g0*bj1/x + el + log(x/2.0_wp) Tty = 2.0_wp*g1*by0/(x*x) - g0*by1/x endif end !***************************************************************************************** !> ! Compute Bessel functions Jv(z) and Yv(z) ! and their derivatives with a complex ! argument and a large order subroutine cjylv(v,z,Cbjv,Cdjv,Cbyv,Cdyv) ! Input: v --- Order of Jv(z) and Yv(z) ! z --- Complex argument ! Output: CBJV --- Jv(z) ! CDJV --- Jv'(z) ! CBYV --- Yv(z) ! CDYV --- Yv'(z) implicit none real(wp) a , v , v0 , vr complex(wp) Cbjv , Cbyv , Cdjv , Cdyv , ceta , cf , cfj , cfy , & & csj , csy , ct , ct2 , cws , z integer i , k , km , l , l0 , lf dimension cf(12) , a(91) km = 12 call cjk(km,a) do l = 1 , 0 , -1 v0 = v - l cws = sqrt(1.0_wp-(z/v0)*(z/v0)) ceta = cws + log(z/v0/(1.0_wp+cws)) ct = 1.0_wp/cws ct2 = ct*ct do k = 1 , km l0 = k*(k+1)/2 + 1 lf = l0 + k cf(k) = a(lf) do i = lf - 1 , l0 , -1 cf(k) = cf(k)*ct2 + a(i) enddo cf(k) = cf(k)*ct**k enddo vr = 1.0_wp/v0 csj = (1.0_wp,0.0_wp) do k = 1 , km csj = csj + cf(k)*vr**k enddo Cbjv = sqrt(ct/(2.0_wp*pi*v0))*exp(v0*ceta)*csj if ( l==1 ) cfj = Cbjv csy = (1.0_wp,0.0_wp) do k = 1 , km csy = csy + (-1)**k*cf(k)*vr**k enddo Cbyv = -sqrt(2.0_wp*ct/(pi*v0))*exp(-v0*ceta)*csy if ( l==1 ) cfy = Cbyv enddo Cdjv = -v/z*Cbjv + cfj Cdyv = -v/z*Cbyv + cfy end !***************************************************************************************** !> ! Compute prolate and oblate spheroidal radial ! functions of the second kind for given m, n, ! c and a large cx subroutine rmn2l(m,n,c,x,Df,Kd,R2f,R2d,Id) real(wp) a0 , b0 , c , cx , Df , dy , eps , eps1 , eps2 , & & r , r0 , R2d , R2f , reg , suc , sud , sw , sy , & & x integer Id , id1 , id2 , ip , j , k , Kd , l , lg , m , n , nm , & & nm1 , nm2 , np dimension Df(200) , sy(0:251) , dy(0:251) eps = 1.0d-14 ip = 1 nm1 = int((n-m)/2) if ( n-m==2*nm1 ) ip = 0 nm = 25 + nm1 + int(c) reg = 1.0_wp if ( m+nm>80 ) reg = 1.0d-200 nm2 = 2*nm + m cx = c*x call sphy(nm2,cx,nm2,sy,dy) r0 = reg do j = 1 , 2*m + ip r0 = r0*j enddo r = r0 suc = r*Df(1) sw = 0.0_wp do k = 2 , nm r = r*(m+k-1.0)*(m+k+ip-1.5d0)/(k-1.0_wp)/(k+ip-1.5d0) suc = suc + r*Df(k) if ( k>nm1 .and. abs(suc-sw)<abs(suc)*eps ) exit sw = suc enddo a0 = (1.0_wp-Kd/(x*x))**(0.5_wp*m)/suc R2f = 0.0_wp eps1 = 0.0_wp np = 0 do k = 1 , nm l = 2*k + m - n - 2 + ip lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0)*(m+k+ip-1.5d0)/(k-1.0_wp)/(k+ip-1.5d0) endif np = m + 2*k - 2 + ip R2f = R2f + lg*r*(Df(k)*sy(np)) eps1 = abs(R2f-sw) if ( k>nm1 .and. eps1<abs(R2f)*eps ) exit sw = R2f enddo id1 = int(log10(eps1/abs(R2f)+eps)) R2f = R2f*a0 if ( np>=nm2 ) then Id = 10 return endif b0 = Kd*m/x**3.0_wp/(1.0-Kd/(x*x))*R2f sud = 0.0_wp eps2 = 0.0_wp do k = 1 , nm l = 2*k + m - n - 2 + ip lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0)*(m+k+ip-1.5d0)/(k-1.0_wp)/(k+ip-1.5d0) endif np = m + 2*k - 2 + ip sud = sud + lg*r*(Df(k)*dy(np)) eps2 = abs(sud-sw) if ( k>nm1 .and. eps2<abs(sud)*eps ) exit sw = sud enddo R2d = b0 + a0*c*sud id2 = int(log10(eps2/abs(sud)+eps)) Id = max(id1,id2) end !***************************************************************************************** !> ! Compute Psi function subroutine psi_spec(x,Ps) ! Input : x --- Argument of psi(x) ! Output: PS --- psi(x) implicit none real(wp) a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , el ,& & Ps , s , x , x2 , xa integer k , n xa = abs(x) el = .5772156649015329d0 s = 0.0_wp if ( x==int(x) .and. x<=0.0 ) then Ps = 1.0e+300_wp return elseif ( xa==int(xa) ) then n = xa do k = 1 , n - 1 s = s + 1.0_wp/k enddo Ps = -el + s elseif ( xa+.5==int(xa+.5) ) then n = xa - .5 do k = 1 , n s = s + 1.0/(2.0_wp*k-1.0_wp) enddo Ps = -el + 2.0_wp*s - 1.386294361119891d0 else if ( xa<10.0 ) then n = 10 - int(xa) do k = 0 , n - 1 s = s + 1.0_wp/(xa+k) enddo xa = xa + n endif x2 = 1.0_wp/(xa*xa) a1 = -.8333333333333d-01 a2 = .83333333333333333d-02 a3 = -.39682539682539683d-02 a4 = .41666666666666667d-02 a5 = -.75757575757575758d-02 a6 = .21092796092796093d-01 a7 = -.83333333333333333d-01 a8 = .4432598039215686d0 Ps = log(xa) - .5d0/xa + & & x2*(((((((a8*x2+a7)*x2+a6)*x2+a5)*x2+a4)*x2+a3)*x2+a2) & & *x2+a1) Ps = Ps - s endif if ( x<0.0 ) Ps = Ps - pi*cos(pi*x)/sin(pi*x) - 1.0_wp/x end !***************************************************************************************** !> ! Calculate a specific characteristic value of ! Mathieu functions subroutine cva2(Kd,m,q,a) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! KD --- Case code ! KD=1 for cem(x,q) ( m = 0,2,4,...) ! KD=2 for cem(x,q) ( m = 1,3,5,...) ! KD=3 for sem(x,q) ( m = 1,3,5,...) ! KD=4 for sem(x,q) ( m = 2,4,6,...) ! Output: A --- Characteristic value implicit none real(wp) a , a1 , a2 , delta , q , q1 , q2 , qq integer i , iflag , Kd , m , ndiv , nn if ( m<=12 .or. q<=3.0*m .or. q>m*m ) then call cv0(Kd,m,q,a) if ( q/=0.0_wp .and. m/=2 ) call refine(Kd,m,q,a) if ( q>2.0d-3 .and. m==2 ) call refine(Kd,m,q,a) else ndiv = 10 delta = (m-3.0)*m/ndiv if ( (q-3.0*m)<=(m*m-q) ) then 20 nn = int((q-3.0*m)/delta) + 1 delta = (q-3.0*m)/nn q1 = 2.0*m call cvqm(m,q1,a1) q2 = 3.0*m call cvqm(m,q2,a2) qq = 3.0*m do i = 1 , nn qq = qq + delta a = (a1*q2-a2*q1+(a2-a1)*qq)/(q2-q1) iflag = 1 if ( i==nn ) iflag = -1 call refine(Kd,m,qq,a) q1 = q2 q2 = qq a1 = a2 a2 = a enddo if ( iflag==-10 ) then ndiv = ndiv*2 delta = (m-3.0)*m/ndiv goto 20 endif else 40 nn = int((m*m-q)/delta) + 1 delta = (m*m-q)/nn q1 = m*(m-1.0) call cvql(Kd,m,q1,a1) q2 = m*m call cvql(Kd,m,q2,a2) qq = m*m do i = 1 , nn qq = qq - delta a = (a1*q2-a2*q1+(a2-a1)*qq)/(q2-q1) iflag = 1 if ( i==nn ) iflag = -1 call refine(Kd,m,qq,a) q1 = q2 q2 = qq a1 = a2 a2 = a enddo if ( iflag==-10 ) then ndiv = ndiv*2 delta = (m-3.0)*m/ndiv goto 40 endif endif endif end !***************************************************************************************** !> ! Compute associated Legendre functions Pmn(x) ! and Pmn'(x) for a given order subroutine lpmns(m,n,x,Pm,Pd) ! Input : x --- Argument of Pmn(x) ! m --- Order of Pmn(x), m = 0,1,2,...,n ! n --- Degree of Pmn(x), n = 0,1,2,...,N ! Output: PM(n) --- Pmn(x) ! PD(n) --- Pmn'(x) integer k , m , n real(wp) Pd , Pm , pm0 , pm1 , pm2 , pmk , x , x0 dimension Pm(0:n) , Pd(0:n) do k = 0 , n Pm(k) = 0.0_wp Pd(k) = 0.0_wp enddo if ( abs(x)==1.0_wp ) then do k = 0 , n if ( m==0 ) then Pm(k) = 1.0_wp Pd(k) = 0.5_wp*k*(k+1.0) if ( x<0.0 ) then Pm(k) = (-1)**k*Pm(k) Pd(k) = (-1)**(k+1)*Pd(k) endif elseif ( m==1 ) then Pd(k) = 1.0e+300_wp elseif ( m==2 ) then Pd(k) = -0.25d0*(k+2.0)*(k+1.0)*k*(k-1.0) if ( x<0.0 ) Pd(k) = (-1)**(k+1)*Pd(k) endif enddo return endif x0 = abs(1.0_wp-x*x) pm0 = 1.0_wp pmk = pm0 do k = 1 , m pmk = (2.0_wp*k-1.0_wp)*sqrt(x0)*pm0 pm0 = pmk enddo pm1 = (2.0_wp*m+1.0_wp)*x*pm0 Pm(m) = pmk Pm(m+1) = pm1 do k = m + 2 , n pm2 = ((2.0_wp*k-1.0_wp)*x*pm1-(k+m-1.0_wp)*pmk)/(k-m) Pm(k) = pm2 pmk = pm1 pm1 = pm2 enddo Pd(0) = ((1.0_wp-m)*Pm(1)-x*Pm(0))/(x*x-1.0) do k = 1 , n Pd(k) = (k*x*Pm(k)-(k+m)*Pm(k-1))/(x*x-1.0_wp) enddo do k = 1 , n Pm(k) = (-1)**m*Pm(k) Pd(k) = (-1)**m*Pd(k) enddo end !***************************************************************************************** !> ! Compute complex Error function erf(z) & erf'(z) subroutine cerf(z,Cer,Cder) ! Input: z --- Complex argument of erf(z) ! x --- Real part of z ! y --- Imaginary part of z ! Output: CER --- erf(z) ! CDER --- erf'(z) real(wp) c0 , cs , ei1 , ei2 , eps , er , er0 , er1 , & & er2 , eri , err , r , ss , w , w1 , w2 , x ,& & x2 , y integer k , n complex(wp) z , Cer , Cder eps = 1.0d-12 x = real(z,wp) y = aimag(z) x2 = x*x if ( x<=3.5d0 ) then er = 1.0_wp r = 1.0_wp w = 0.0_wp do k = 1 , 100 r = r*x2/(k+0.5_wp) er = er + r if ( abs(er-w)<=eps*abs(er) ) exit w = er enddo c0 = 2.0_wp/sqrtpi*x*exp(-x2) er0 = c0*er else er = 1.0_wp r = 1.0_wp do k = 1 , 12 r = -r*(k-0.5_wp)/x2 er = er + r enddo c0 = exp(-x2)/(x*sqrtpi) er0 = 1.0_wp - c0*er endif if ( y==0.0_wp ) then err = er0 eri = 0.0_wp else cs = cos(2.0_wp*x*y) ss = sin(2.0_wp*x*y) er1 = exp(-x2)*(1.0_wp-cs)/(2.0_wp*pi*x) ei1 = exp(-x2)*ss/(2.0_wp*pi*x) er2 = 0.0_wp w1 = 0.0_wp do n = 1 , 100 er2 = er2 + exp(-0.25_wp*n*n)/(n*n+4.0_wp*x2) & & *(2.0_wp*x-2.0_wp*x*cosh(n*y)*cs+n*sinh(n*y)*ss) if ( abs((er2-w1)/er2)<eps ) exit w1 = er2 enddo c0 = 2.0_wp*exp(-x2)/pi err = er0 + er1 + c0*er2 ei2 = 0.0_wp w2 = 0.0_wp do n = 1 , 100 ei2 = ei2 + exp(-0.25_wp*n*n)/(n*n+4.0_wp*x2) & & *(2.0_wp*x*cosh(n*y)*ss+n*sinh(n*y)*cs) if ( abs((ei2-w2)/ei2)<eps ) exit w2 = ei2 enddo eri = ei1 + c0*ei2 endif Cer = dcmplx(err,eri) Cder = 2.0_wp/sqrtpi*exp(-z*z) end !***************************************************************************************** !> ! Compute prolate spheriodal radial functions of the ! first and second kinds, and their derivatives subroutine rswfp(m,n,c,x,Cv,Kf,R1f,R1d,R2f,R2d) ! Input : m --- Mode parameter, m = 0,1,2,... ! n --- Mode parameter, n = m,m+1,m+2,... ! c --- Spheroidal parameter ! x --- Argument of radial function ( x > 1.0 ) ! cv --- Characteristic value ! KF --- Function code ! KF=1 for the first kind ! KF=2 for the second kind ! KF=3 for both the first and second kinds ! Output: R1F --- Radial function of the first kind ! R1D --- Derivative of the radial function of ! the first kind ! R2F --- Radial function of the second kind ! R2D --- Derivative of the radial function of ! the second kind implicit none real(wp) c , Cv , df , R1d , R1f , R2d , R2f , x integer id , kd , Kf , m , n dimension df(200) kd = 1 call sdmn(m,n,c,Cv,kd,df) if ( Kf/=2 ) call rmn1(m,n,c,x,df,kd,R1f,R1d) if ( Kf>1 ) then call rmn2l(m,n,c,x,df,kd,R2f,R2d,id) if ( id>-8 ) call rmn2sp(m,n,c,x,Cv,df,kd,R2f,R2d) endif end !***************************************************************************************** !> ! Compute Bessel functions Jn(x) and Yn(x), and ! their first and second derivatives subroutine jyndd(n,x,Bjn,Djn,Fjn,Byn,Dyn,Fyn) ! Input: x --- Argument of Jn(x) and Yn(x) ( x > 0 ) ! n --- Order of Jn(x) and Yn(x) ! Output: BJN --- Jn(x) ! DJN --- Jn'(x) ! FJN --- Jn"(x) ! BYN --- Yn(x) ! DYN --- Yn'(x) ! FYN --- Yn"(x) real(wp) bj , Bjn , by , Byn , Djn , Dyn , Fjn , Fyn , x integer n , nm dimension bj(2) , by(2) call jynbh(n+1,n,x,nm,bj,by) ! Compute derivatives by differentiation formulas Bjn = bj(1) Byn = by(1) Djn = -bj(2) + n*bj(1)/x Dyn = -by(2) + n*by(1)/x Fjn = (n*n/(x*x)-1.0_wp)*Bjn - Djn/x Fyn = (n*n/(x*x)-1.0_wp)*Byn - Dyn/x end !***************************************************************************************** !> ! Compute gamma function Г(x) subroutine gam0(x,Ga) ! Input : x --- Argument of Г(x) ( |x| ≤ 1 ) ! Output: GA --- Г(x) real(wp) g , Ga , gr , x integer k dimension g(25) data g/1.0_wp , 0.5772156649015329d0 , -0.6558780715202538d0 , & & -0.420026350340952d-1 , 0.1665386113822915d0 , & & -.421977345555443d-1 , -.96219715278770d-2 , & & .72189432466630d-2 , -.11651675918591d-2 , & & -.2152416741149d-3 , .1280502823882d-3 , -.201348547807d-4 , & & -.12504934821d-5 , .11330272320d-5 , -.2056338417d-6 , & & .61160950d-8 , .50020075d-8 , -.11812746d-8 , .1043427d-9 , & & .77823d-11 , -.36968d-11 , .51d-12 , -.206d-13 , -.54d-14 , & & .14d-14/ gr = (25) do k = 24 , 1 , -1 gr = gr*x + g(k) enddo Ga = 1.0_wp/(gr*x) end !***************************************************************************************** !> ! Compute cosine and sine integrals ! Si(x) and Ci(x) ( x ≥ 0 ) subroutine cisib(x,Ci,Si) ! Input : x --- Argument of Ci(x) and Si(x) ! Output: CI --- Ci(x) ! SI --- Si(x) real(wp) Ci , fx , gx , Si , x , x2 x2 = x*x if ( x==0.0 ) then Ci = -1.0e+300_wp Si = 0.0_wp elseif ( x<=1.0_wp ) then Ci = ((((-3.0d-8*x2+3.10d-6)*x2-2.3148d-4)*x2+1.041667d-2) & & *x2-0.25)*x2 + 0.577215665d0 + log(x) Si = ((((3.1d-7*x2-2.834d-5)*x2+1.66667d-003)*x2-5.555556d-002)& & *x2+1.0)*x else fx = ((((x2+38.027264d0)*x2+265.187033d0)*x2+335.67732d0) & & *x2+38.102495d0) & & /((((x2+40.021433d0)*x2+322.624911d0)*x2+570.23628d0) & & *x2+157.105423d0) gx = ((((x2+42.242855d0)*x2+302.757865d0)*x2+352.018498d0) & & *x2+21.821899d0) & & /((((x2+48.196927d0)*x2+482.485984d0)*x2+1114.978885d0) & & *x2+449.690326d0)/x Ci = fx*sin(x)/x - gx*cos(x)/x Si = 1.570796327d0 - fx*cos(x)/x - gx*sin(x)/x endif end !***************************************************************************************** !> ! Compute Euler number En subroutine eulera(n,En) ! Input : n --- Serial number ! Output: EN(n) --- En real(wp) En , r , s integer j , k , m , n dimension En(0:n) En(0) = 1.0_wp do m = 1 , n/2 s = 1.0_wp do k = 1 , m - 1 r = 1.0_wp do j = 1 , 2*k r = r*(2.0_wp*m-2.0_wp*k+j)/j enddo s = s + r*En(2*k) enddo En(2*m) = -s enddo end !***************************************************************************************** !> ! calculate the accurate characteristic value ! by the secant method subroutine refine(Kd,m,q,a) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! A --- Initial characteristic value ! Output: A --- Refineed characteristic value real(wp) a , ca , delta , eps , f , f0 , f1 , q , x , x0 ,& & x1 integer it , Kd , m , mj eps = 1.0d-14 mj = 10 + m ca = a delta = 0.0_wp x0 = a call cvf(Kd,m,q,x0,mj,f0) x1 = 1.002*a call cvf(Kd,m,q,x1,mj,f1) do it = 1 , 100 mj = mj + 1 x = x1 - (x1-x0)/(1.0_wp-f0/f1) call cvf(Kd,m,q,x,mj,f) if ( abs(1.0-x1/x)<eps .or. f==0.0 ) exit x0 = x1 f0 = f1 x1 = x f1 = f enddo a = x end !***************************************************************************************** !> ! Compute cosine and sine integrals ! Si(x) and Ci(x) ( x ≥ 0 ) subroutine cisia(x,Ci,Si) ! Input : x --- Argument of Ci(x) and Si(x) ! Output: CI --- Ci(x) ! SI --- Si(x) real(wp) bj , Ci , el , eps , p2 , Si , x , x2 , xa , & & xa0 , xa1 , xcs , xf , xg , xg1 , xg2 , xr , xs ,& & xss integer k , m dimension bj(101) p2 = 1.570796326794897d0 el = .5772156649015329d0 eps = 1.0d-15 x2 = x*x if ( x==0.0_wp ) then Ci = -1.0e+300_wp Si = 0.0_wp elseif ( x<=16.0d0 ) then xr = -0.25_wp*x2 Ci = el + log(x) + xr do k = 2 , 40 xr = -0.5_wp*xr*(k-1)/(k*k*(2*k-1))*x2 Ci = Ci + xr if ( abs(xr)<abs(Ci)*eps ) exit enddo xr = x Si = x do k = 1 , 40 xr = -0.5_wp*xr*(2*k-1)/k/(4*k*k+4*k+1)*x2 Si = Si + xr if ( abs(xr)<abs(Si)*eps ) return enddo elseif ( x<=32.0d0 ) then m = int(47.2+.82*x) xa1 = 0.0_wp xa0 = 1.0d-100 do k = m , 1 , -1 xa = 4.0_wp*k*xa0/x - xa1 bj(k) = xa xa1 = xa0 xa0 = xa enddo xs = bj(1) do k = 3 , m , 2 xs = xs + 2.0_wp*bj(k) enddo bj(1) = bj(1)/xs do k = 2 , m bj(k) = bj(k)/xs enddo xr = 1.0_wp xg1 = bj(1) do k = 2 , m xr = .25d0*xr*(2.0*k-3.0)**2/((k-1.0)*(2.0*k-1.0)**2)*x xg1 = xg1 + bj(k)*xr enddo xr = 1.0_wp xg2 = bj(1) do k = 2 , m xr = .25d0*xr*(2.0*k-5.0)**2/((k-1.0)*(2.0*k-3.0)**2)*x xg2 = xg2 + bj(k)*xr enddo xcs = cos(x/2.0_wp) xss = sin(x/2.0_wp) Ci = el + log(x) - x*xss*xg1 + 2*xcs*xg2 - 2*xcs*xcs Si = x*xcs*xg1 + 2*xss*xg2 - sin(x) else xr = 1.0_wp xf = 1.0_wp do k = 1 , 9 xr = -2.0_wp*xr*k*(2*k-1)/x2 xf = xf + xr enddo xr = 1.0_wp/x xg = xr do k = 1 , 8 xr = -2.0_wp*xr*(2*k+1)*k/x2 xg = xg + xr enddo Ci = xf*sin(x)/x - xg*cos(x)/x Si = p2 - xf*cos(x)/x - xg*sin(x)/x endif end !***************************************************************************************** !> ! Evaluate the integral of modified Struve function ! L0(t) with respect to t from 0 to x subroutine itsl0(x,Tl0) ! Input : x --- Upper limit ( x ≥ 0 ) ! Output: TL0 --- Integration of L0(t) from 0 to x real(wp) a , a0 , a1 , af , el , r , rd , s , s0 , & & ti , Tl0 , x integer k dimension a(18) r = 1.0_wp if ( x<=20.0 ) then s = 0.5_wp do k = 1 , 100 rd = 1.0_wp if ( k==1 ) rd = 0.5_wp r = r*rd*k/(k+1.0_wp)*(x/(2.0_wp*k+1.0_wp))**2 s = s + r if ( abs(r/s)<1.0d-12 ) exit enddo Tl0 = 2.0_wp/pi*x*x*s else s = 1.0_wp do k = 1 , 10 r = r*k/(k+1.0_wp)*((2.0_wp*k+1.0_wp)/x)**2 s = s + r if ( abs(r/s)<1.0d-12 ) exit enddo el = .57721566490153d0 s0 = -s/(pi*x*x) + 2.0_wp/pi*(log(2.0_wp*x)+el) a0 = 1.0_wp a1 = 5.0_wp/8.0_wp a(1) = a1 do k = 1 , 10 af = ((1.5d0*(k+.50d0)*(k+5.0_wp/6.0_wp)*a1-0.5_wp*(k+.5d0) & & **2*(k-0.5_wp)*a0))/(k+1.0_wp) a(k+1) = af a0 = a1 a1 = af enddo ti = 1.0_wp r = 1.0_wp do k = 1 , 11 r = r/x ti = ti + a(k)*r enddo Tl0 = ti/sqrt(2*pi*x)*exp(x) + s0 endif end !***************************************************************************************** !> ! Compute the Legendre functions Qn(z) and ! their derivatives Qn'(z) for a complex ! argument subroutine clqn(n,x,y,Cqn,Cqd) ! Input : x --- Real part of z ! y --- Imaginary part of z ! n --- Degree of Qn(z), n = 0,1,2,... ! Output: CQN(n) --- Qn(z) ! CQD(n) --- Qn'(z) complex(wp) cq0 , cq1 , Cqd , cqf0 , cqf1 , cqf2 , Cqn , z integer k , km , ls , n real(wp) x , y dimension Cqn(0:n) , Cqd(0:n) z = dcmplx(x,y) if ( z==1.0_wp ) then do k = 0 , n Cqn(k) = (1.0e+300_wp,0.0_wp) Cqd(k) = (1.0e+300_wp,0.0_wp) enddo return endif ls = 1 if ( abs(z)>1.0_wp ) ls = -1 cq0 = 0.5_wp*log(ls*(1.0_wp+z)/(1.0_wp-z)) cq1 = z*cq0 - 1.0_wp Cqn(0) = cq0 Cqn(1) = cq1 if ( abs(z)<1.0001_wp ) then cqf0 = cq0 cqf1 = cq1 do k = 2 , n cqf2 = ((2.0_wp*k-1.0_wp)*z*cqf1-(k-1.0_wp)*cqf0)/k Cqn(k) = cqf2 cqf0 = cqf1 cqf1 = cqf2 enddo else if ( abs(z)>1.1_wp ) then km = 40 + n else km = (40+n)*int(-1.0-1.8*log(abs(z-1.0))) endif cqf2 = 0.0_wp cqf1 = 1.0_wp do k = km , 0 , -1 cqf0 = ((2*k+3.0_wp)*z*cqf1-(k+2.0_wp)*cqf2)/(k+1.0_wp) if ( k<=n ) Cqn(k) = cqf0 cqf2 = cqf1 cqf1 = cqf0 enddo do k = 0 , n Cqn(k) = Cqn(k)*cq0/cqf0 enddo endif Cqd(0) = (Cqn(1)-z*Cqn(0))/(z*z-1.0_wp) do k = 1 , n Cqd(k) = (k*z*Cqn(k)-k*Cqn(k-1))/(z*z-1.0_wp) enddo end !***************************************************************************************** !> ! Compute the first NT zeros of Airy functions ! Ai(x) and Ai'(x), a and a', and the associated ! values of Ai(a') and Ai'(a); and the first NT ! zeros of Airy functions Bi(x) and Bi'(x), b and ! b', and the associated values of Bi(b') and ! Bi'(b) subroutine airyzo(Nt,Kf,Xa,Xb,Xc,Xd) ! Input : NT --- Total number of zeros ! KF --- Function code ! KF=1 for Ai(x) and Ai'(x) ! KF=2 for Bi(x) and Bi'(x) ! Output: XA(m) --- a, the m-th zero of Ai(x) or ! b, the m-th zero of Bi(x) ! XB(m) --- a', the m-th zero of Ai'(x) or ! b', the m-th zero of Bi'(x) ! XC(m) --- Ai(a') or Bi(b') ! XD(m) --- Ai'(a) or Bi'(b) ! ( m --- Serial number of zeros ) real(wp) ad , ai , bd , bi , err , rt , rt0 , u , & & u1 , x , Xa , Xb , Xc , Xd integer i , Kf , Nt dimension Xa(Nt) , Xb(Nt) , Xc(Nt) , Xd(Nt) rt = 0.0_wp do i = 1 , Nt rt0 = 0d0 if ( Kf==1 ) then u = 3.0_wp*pi*(4.0_wp*i-1)/8.0_wp u1 = 1/(u*u) elseif ( Kf==2 ) then if ( i==1 ) then rt0 = -1.17371d0 else u = 3.0_wp*pi*(4.0_wp*i-3.0_wp)/8.0_wp u1 = 1/(u*u) endif endif ! DLMF 9.9.18 if ( rt0==0 ) rt0 = -(u*u)**(1.0_wp/3.0_wp) & & *(+1d0+u1*(5d0/48d0+u1* & & (-5d0/36d0+u1*(77125d0/82944d0+ & & u1*(-108056875d0/6967296d0))))) 50 x = rt0 call airyb(x,ai,bi,ad,bd) if ( Kf==1 ) rt = rt0 - ai/ad if ( Kf==2 ) rt = rt0 - bi/bd err = abs((rt-rt0)/rt) if ( err>1.d-12 ) then rt0 = rt goto 50 else Xa(i) = rt if ( err>1d-14 ) call airyb(rt,ai,bi,ad,bd) if ( Kf==1 ) Xd(i) = ad if ( Kf==2 ) Xd(i) = bd endif enddo do i = 1 , Nt rt0 = 0d0 if ( Kf==1 ) then if ( i==1 ) then rt0 = -1.01879d0 else u = 3.0_wp*pi*(4.0_wp*i-3.0_wp)/8.0_wp u1 = 1/(u*u) endif elseif ( Kf==2 ) then if ( i==1 ) then rt0 = -2.29444d0 else u = 3.0_wp*pi*(4.0_wp*i-1.0_wp)/8.0_wp u1 = 1/(u*u) endif endif ! DLMF 9.9.19 if ( rt0==0 ) rt0 = -(u*u)**(1.0_wp/3.0_wp) & & *(+1d0+u1*(-7d0/48d0+u1* & & (+35d0/288d0+u1*(-181223d0/207360d0+ & & u1*(18683371d0/1244160d0))))) 100 x = rt0 call airyb(x,ai,bi,ad,bd) if ( Kf==1 ) rt = rt0 - ad/(ai*x) if ( Kf==2 ) rt = rt0 - bd/(bi*x) err = abs((rt-rt0)/rt) if ( err>1.0d-12 ) then rt0 = rt goto 100 else Xb(i) = rt if ( err>1d-14 ) call airyb(rt,ai,bi,ad,bd) if ( Kf==1 ) Xc(i) = ai if ( Kf==2 ) Xc(i) = bi endif enddo end !***************************************************************************************** !> ! Compute error function erf(x) subroutine error(x,Err) ! Input: x --- Argument of erf(x) ! Output: ERR --- erf(x) real(wp) c0 , eps , er , Err , r , x , x2 integer k eps = 1.0d-15 x2 = x*x if ( abs(x)<3.5d0 ) then er = 1.0_wp r = 1.0_wp do k = 1 , 50 r = r*x2/(k+0.5_wp) er = er + r if ( abs(r)<=abs(er)*eps ) exit enddo c0 = 2.0_wp/sqrtpi*x*exp(-x2) Err = c0*er else er = 1.0_wp r = 1.0_wp do k = 1 , 12 r = -r*(k-0.5_wp)/x2 er = er + r enddo c0 = exp(-x2)/(abs(x)*sqrtpi) Err = 1.0_wp - c0*er if ( x<0.0 ) Err = -Err endif end !***************************************************************************************** !> ! Compute error function erf(z) for a complex ! argument (z=x+iy) subroutine cerror(z,Cer) ! Input : z --- Complex argument ! Output: CER --- erf(z) complex(wp) c0 , Cer , cl , cr , cs , z , z1 integer k real(wp) a0 a0 = abs(z) c0 = exp(-z*z) z1 = z if ( real(z,wp)<0.0 ) z1 = -z ! ! Cutoff radius R = 4.36; determined by balancing rounding error ! and asymptotic expansion error, see below. ! ! The resulting maximum global accuracy expected is around 1e-8 ! if ( a0<=4.36d0 ) then ! ! Rounding error in the Taylor expansion is roughly ! ! ~ R*R * EPSILON * R**(2 R**2) / (2 R**2 Gamma(R**2 + 1/2)) ! cs = z1 cr = z1 do k = 1 , 120 cr = cr*z1*z1/(k+0.5_wp) cs = cs + cr if ( abs(cr/cs)<1.0d-15 ) exit enddo Cer = 2.0_wp*c0*cs/sqrtpi else cl = 1.0_wp/z1 cr = cl ! ! Asymptotic series; maximum K must be at most ~ R^2. ! ! The maximum accuracy obtainable from this expansion is roughly ! ! ~ Gamma(2R**2 + 2) / ( ! (2 R**2)**(R**2 + 1/2) Gamma(R**2 + 3/2) 2**(R**2 + 1/2)) ! do k = 1 , 20 cr = -cr*(k-0.5_wp)/(z1*z1) cl = cl + cr if ( abs(cr/cl)<1.0d-15 ) exit enddo Cer = 1.0_wp - c0*cl/sqrtpi endif if ( real(z,wp)<0.0 ) Cer = -Cer end !***************************************************************************************** !> ! Compute Euler number En subroutine eulerb(n,En) ! Input : n --- Serial number ! Output: EN(n) --- En real(wp) En , hpi , r1 , r2 , s integer isgn , k , m , n dimension En(0:n) hpi = 2.0_wp/3.141592653589793d0 En(0) = 1.0_wp En(2) = -1.0_wp r1 = -4.0_wp*hpi**3 do m = 4 , n , 2 r1 = -r1*(m-1)*m*hpi*hpi r2 = 1.0_wp isgn = 1.0_wp do k = 3 , 1000 , 2 isgn = -isgn s = (1.0_wp/k)**(m+1) r2 = r2 + isgn*s if ( s<1.0d-15 ) exit enddo En(m) = r1*r2 enddo end !***************************************************************************************** !> ! Compute a sequence of characteristic values of ! Mathieu functions subroutine cva1(Kd,m,q,Cv) ! Input : M --- Maximum order of Mathieu functions ! q --- Parameter of Mathieu functions ! KD --- Case code ! KD=1 for cem(x,q) ( m = 0,2,4,… ) ! KD=2 for cem(x,q) ( m = 1,3,5,… ) ! KD=3 for sem(x,q) ( m = 1,3,5,… ) ! KD=4 for sem(x,q) ( m = 2,4,6,… ) ! Output: CV(I) --- Characteristic values; I = 1,2,3,... ! For KD=1, CV(1), CV(2), CV(3),..., correspond to ! the characteristic values of cem for m = 0,2,4,... ! For KD=2, CV(1), CV(2), CV(3),..., correspond to ! the characteristic values of cem for m = 1,3,5,... ! For KD=3, CV(1), CV(2), CV(3),..., correspond to ! the characteristic values of sem for m = 1,3,5,... ! For KD=4, CV(1), CV(2), CV(3),..., correspond to ! the characteristic values of sem for m = 0,2,4,... implicit none real(wp) Cv , d , e , eps , f , g , h , q , s , t , t1 , & & x1 , xa , xb integer i , ic , icm , j , k , k1 , Kd , m , nm , nm1 dimension g(200) , h(200) , d(500) , e(500) , f(500) , Cv(200) eps = 1.0d-14 icm = int(m/2) + 1 if ( Kd==4 ) icm = m/2 if ( q/=0.0_wp ) then nm = int(10+1.5*m+0.5*q) e(1) = 0.0_wp f(1) = 0.0_wp if ( Kd==1 ) then d(1) = 0.0_wp do i = 2 , nm d(i) = 4.0_wp*(i-1.0_wp)**2 e(i) = q f(i) = q*q enddo e(2) = sqrt(2.0_wp)*q f(2) = 2.0_wp*q*q elseif ( Kd/=4 ) then d(1) = 1.0_wp + (-1)**Kd*q do i = 2 , nm d(i) = (2.0_wp*i-1.0_wp)**2 e(i) = q f(i) = q*q enddo else d(1) = 4.0_wp do i = 2 , nm d(i) = 4.0_wp*i*i e(i) = q f(i) = q*q enddo endif xa = d(nm) + abs(e(nm)) xb = d(nm) - abs(e(nm)) nm1 = nm - 1 do i = 1 , nm1 t = abs(e(i)) + abs(e(i+1)) t1 = d(i) + t if ( xa<t1 ) xa = t1 t1 = d(i) - t if ( t1<xb ) xb = t1 enddo do i = 1 , icm g(i) = xa h(i) = xb enddo do k = 1 , icm do k1 = k , icm if ( g(k1)<g(k) ) then g(k) = g(k1) exit endif enddo if ( k/=1 .and. h(k)<h(k-1) ) h(k) = h(k-1) 40 x1 = (g(k)+h(k))/2.0_wp Cv(k) = x1 if ( abs((g(k)-h(k))/x1)<eps ) then Cv(k) = x1 else j = 0 s = 1.0_wp do i = 1 , nm if ( s==0.0_wp ) s = s + 1.0d-30 t = f(i)/s s = d(i) - t - x1 if ( s<0.0 ) j = j + 1 enddo if ( j<k ) then h(k) = x1 else g(k) = x1 if ( j>=icm ) then g(icm) = x1 else if ( h(j+1)<x1 ) h(j+1) = x1 if ( x1<g(j) ) g(j) = x1 endif endif goto 40 endif enddo elseif ( Kd==1 ) then do ic = 1 , icm Cv(ic) = 4.0_wp*(ic-1.0_wp)**2 enddo elseif ( Kd/=4 ) then do ic = 1 , icm Cv(ic) = (2.0_wp*ic-1.0_wp)**2 enddo else do ic = 1 , icm Cv(ic) = 4.0_wp*ic*ic enddo endif end !***************************************************************************************** !> ! Integrate [I0(t)-1]/t with respect to t from 0 ! to x, and K0(t)/t with respect to t from x to ∞ subroutine ittikb(x,Tti,Ttk) ! Input : x --- Variable in the limits ( x ≥ 0 ) ! Output: TTI --- Integration of [I0(t)-1]/t from 0 to x ! TTK --- Integration of K0(t)/t from x to ∞ real(wp) e0 , el , t , t1 , Tti , Ttk , x , x1 el = .5772156649015329d0 if ( x==0.0_wp ) then Tti = 0.0_wp elseif ( x<=5.0_wp ) then x1 = x/5.0_wp t = x1*x1 Tti = (((((((.1263d-3*t+.96442d-3)*t+.968217d-2)*t+.06615507d0)& & *t+.33116853d0)*t+1.13027241d0)*t+2.44140746d0) & & *t+3.12499991d0)*t else t = 5.0_wp/x Tti = (((((((((2.1945464d0*t-3.5195009d0)*t-11.9094395d0)*t+ & & 40.394734d0)*t-48.0524115d0)*t+28.1221478d0) & & *t-8.6556013d0)*t+1.4780044d0)*t-.0493843d0) & & *t+.1332055d0)*t + .3989314d0 Tti = Tti*exp(x)/(sqrt(x)*x) endif if ( x==0.0_wp ) then Ttk = 1.0e+300_wp elseif ( x<=2.0_wp ) then t1 = x/2.0_wp t = t1*t1 Ttk = (((((.77d-6*t+.1544d-4)*t+.48077d-3)*t+.925821d-2) & & *t+.10937537d0)*t+.74999993d0)*t e0 = el + log(x/2.0_wp) Ttk = pi*pi/24.0d0 + e0*(0.5_wp*e0+Tti) - Ttk elseif ( x<=4.0_wp ) then t = 2.0_wp/x Ttk = (((.06084d0*t-.280367d0)*t+.590944d0)*t-.850013d0) & & *t + 1.234684d0 Ttk = Ttk*exp(-x)/(sqrt(x)*x) else t = 4.0_wp/x Ttk = (((((.02724d0*t-.1110396d0)*t+.2060126d0)*t-.2621446d0) & & *t+.3219184d0)*t-.5091339d0)*t + 1.2533141d0 Ttk = Ttk*exp(-x)/(sqrt(x)*x) endif end !***************************************************************************************** !> ! Compute Legendre functions Qn(x) & Qn'(x) subroutine lqnb(n,x,Qn,Qd) ! Input : x --- Argument of Qn(x) ! n --- Degree of Qn(x) ( n = 0,1,2,…) ! Output: QN(n) --- Qn(x) ! QD(n) --- Qn'(x) real(wp) eps , q0 , q1 , qc1 , qc2 , Qd , qf , qf0 , qf1 ,& & qf2 , Qn , qr , x , x2 integer j , k , l , n , nl dimension Qn(0:n) , Qd(0:n) eps = 1.0d-14 if ( abs(x)==1.0_wp ) then do k = 0 , n Qn(k) = 1.0e+300_wp Qd(k) = 1.0e+300_wp enddo return endif if ( x<=1.021d0 ) then x2 = abs((1.0_wp+x)/(1.0_wp-x)) q0 = 0.5_wp*log(x2) q1 = x*q0 - 1.0_wp Qn(0) = q0 Qn(1) = q1 Qd(0) = 1.0_wp/(1.0_wp-x*x) Qd(1) = Qn(0) + x*Qd(0) do k = 2 , n qf = ((2.0_wp*k-1.0_wp)*x*q1-(k-1.0_wp)*q0)/k Qn(k) = qf Qd(k) = (Qn(k-1)-x*qf)*k/(1.0_wp-x*x) q0 = q1 q1 = qf enddo else qc1 = 0.0_wp qc2 = 1.0_wp/x do j = 1 , n qc2 = qc2*j/((2.0*j+1.0_wp)*x) if ( j==n-1 ) qc1 = qc2 enddo do l = 0 , 1 nl = n + l qf = 1.0_wp qr = 1.0_wp do k = 1 , 500 qr = qr*(0.5_wp*nl+k-1.0_wp)*(0.5_wp*(nl-1)+k) & & /((nl+k-0.5_wp)*k*x*x) qf = qf + qr if ( abs(qr/qf)<eps ) exit enddo if ( l==0 ) then Qn(n-1) = qf*qc1 else Qn(n) = qf*qc2 endif enddo qf2 = Qn(n) qf1 = Qn(n-1) do k = n , 2 , -1 qf0 = ((2*k-1.0_wp)*x*qf1-k*qf2)/(k-1.0_wp) Qn(k-2) = qf0 qf2 = qf1 qf1 = qf0 enddo Qd(0) = 1.0_wp/(1.0_wp-x*x) do k = 1 , n Qd(k) = k*(Qn(k-1)-x*Qn(k))/(1.0_wp-x*x) enddo endif end !***************************************************************************************** !> ! Compute the expansion coefficients for the ! asymptotic expansion of Bessel functions ! with large orders subroutine cjk(Km,a) ! Input : Km --- Maximum k ! Output: A(L) --- Cj(k) where j and k are related to L ! by L=j+1+[k*(k+1)]/2; j,k=0,1,...,Km real(wp) a , f , f0 , g , g0 integer j , k , Km , l1 , l2 , l3 , l4 dimension a(*) a(1) = 1.0_wp f0 = 1.0_wp g0 = 1.0_wp do k = 0 , Km - 1 l1 = (k+1)*(k+2)/2 + 1 l2 = (k+1)*(k+2)/2 + k + 2 f = (0.5_wp*k+0.125d0/(k+1))*f0 g = -(1.5d0*k+0.625d0/(3.0*(k+1.0_wp)))*g0 a(l1) = f a(l2) = g f0 = f g0 = g enddo do k = 1 , Km - 1 do j = 1 , k l3 = k*(k+1)/2 + j + 1 l4 = (k+1)*(k+2)/2 + j + 1 a(l4) = (j+0.5_wp*k+0.125d0/(2.0*j+k+1.0))*a(l3) & & - (j+0.5_wp*k-1.0+0.625d0/(2.0*j+k+1.0))*a(l3-1) enddo enddo end !***************************************************************************************** !> ! Integrate [I0(t)-1]/t with respect to t from 0 ! to x, and K0(t)/t with respect to t from x to ∞ subroutine ittika(x,Tti,Ttk) ! Input : x --- Variable in the limits ( x ≥ 0 ) ! Output: TTI --- Integration of [I0(t)-1]/t from 0 to x ! TTK --- Integration of K0(t)/t from x to ∞ real(wp) b1 , c , e0 , el , r , r2 , rc , rs , Tti , & & Ttk , x integer k dimension c(8) el = .5772156649015329d0 data c/1.625d0 , 4.1328125d0 , 1.45380859375d+1 , & & 6.553353881835d+1 , 3.6066157150269d+2 , 2.3448727161884d+3 ,& & 1.7588273098916d+4 , 1.4950639538279d+5/ if ( x==0.0_wp ) then Tti = 0.0_wp Ttk = 1.0e+300_wp return endif if ( x<40.0d0 ) then Tti = 1.0_wp r = 1.0_wp do k = 2 , 50 r = .25d0*r*(k-1.0_wp)/(k*k*k)*x*x Tti = Tti + r if ( abs(r/Tti)<1.0d-12 ) exit enddo Tti = Tti*.125d0*x*x else Tti = 1.0_wp r = 1.0_wp do k = 1 , 8 r = r/x Tti = Tti + c(k)*r enddo rc = x*sqrt(2.0_wp*pi*x) Tti = Tti*exp(x)/rc endif if ( x<=12.0d0 ) then e0 = (0.5_wp*log(x/2.0_wp)+el)*log(x/2.0_wp) + pi*pi/24.0d0 + & & .5d0*el*el b1 = 1.5d0 - (el+log(x/2.0_wp)) rs = 1.0_wp r = 1.0_wp do k = 2 , 50 r = .25d0*r*(k-1.0_wp)/(k*k*k)*x*x rs = rs + 1.0_wp/k r2 = r*(rs+1.0_wp/(2.0_wp*k)-(el+log(x/2.0_wp))) b1 = b1 + r2 if ( abs(r2/b1)<1.0d-12 ) exit enddo Ttk = e0 - .125d0*x*x*b1 else Ttk = 1.0_wp r = 1.0_wp do k = 1 , 8 r = -r/x Ttk = Ttk + c(k)*r enddo rc = x*sqrt(2.0_wp/pi*x) Ttk = Ttk*exp(-x)/rc endif end !***************************************************************************************** !> ! Compute lambda function with arbitrary order v, ! and their derivative subroutine lamv(v,x,Vm,Vl,Dl) ! Input : x --- Argument of lambda function ! v --- Order of lambda function ! Output: VL(n) --- Lambda function of order n+v0 ! DL(n) --- Derivative of lambda function ! VM --- Highest order computed ! Routines called: ! (1) MSTA1 and MSTA2 for computing the starting ! point for backward recurrence ! (2) GAM0 for computing gamma function (|x| ≤ 1) real(wp) a0 , bjv0 , bjv1 , bk , ck , cs , Dl , f , f0 , & & f1 , f2 , fac , ga , px , qx , r , r0 , rc ,& & rp real(wp) rp2 , rq , sk , uk , v , v0 , vk , Vl , Vm , vv ,& & x , x2 , xk integer i , j , k , k0 , m , n dimension Vl(0:*) , Dl(0:*) rp2 = 0.63661977236758d0 x = abs(x) x2 = x*x n = int(v) v0 = v - n Vm = v if ( x<=12.0d0 ) then do k = 0 , n vk = v0 + k bk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25d0*r*x2/(i*(i+vk)) bk = bk + r if ( abs(r)<abs(bk)*1.0d-15 ) exit enddo Vl(k) = bk uk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25d0*r*x2/(i*(i+vk+1.0_wp)) uk = uk + r if ( abs(r)<abs(uk)*1.0d-15 ) exit enddo Dl(k) = -0.5_wp*x/(vk+1.0_wp)*uk enddo return endif k0 = 11 if ( x>=35.0d0 ) k0 = 10 if ( x>=50.0d0 ) k0 = 8 bjv0 = 0.0_wp bjv1 = 0.0_wp do j = 0 , 1 vv = 4.0_wp*(j+v0)*(j+v0) px = 1.0_wp rp = 1.0_wp do k = 1 , k0 rp = -0.78125d-2*rp*(vv-(4.0*k-3.0)**2.0) & & *(vv-(4.0*k-1.0)**2.0)/(k*(2.0*k-1.0)*x2) px = px + rp enddo qx = 1.0_wp rq = 1.0_wp do k = 1 , k0 rq = -0.78125d-2*rq*(vv-(4.0*k-1.0)**2.0) & & *(vv-(4.0*k+1.0)**2.0)/(k*(2.0*k+1.0)*x2) qx = qx + rq enddo qx = 0.125d0*(vv-1.0_wp)*qx/x xk = x - (0.5_wp*(j+v0)+0.25d0)*pi a0 = sqrt(rp2/x) ck = cos(xk) sk = sin(xk) if ( j==0 ) bjv0 = a0*(px*ck-qx*sk) if ( j==1 ) bjv1 = a0*(px*ck-qx*sk) enddo if ( v0==0.0_wp ) then ga = 1.0_wp else call gam0(v0,ga) ga = v0*ga endif fac = (2.0_wp/x)**v0*ga Vl(0) = bjv0 Dl(0) = -bjv1 + v0/x*bjv0 Vl(1) = bjv1 Dl(1) = bjv0 - (1.0_wp+v0)/x*bjv1 r0 = 2.0_wp*(1.0_wp+v0)/x if ( n<=1 ) then Vl(0) = fac*Vl(0) Dl(0) = fac*Dl(0) - v0/x*Vl(0) Vl(1) = fac*r0*Vl(1) Dl(1) = fac*r0*Dl(1) - (1.0_wp+v0)/x*Vl(1) return endif if ( n>=2 .and. n<=int(0.9*x) ) then f0 = bjv0 f1 = bjv1 do k = 2 , n f = 2.0_wp*(k+v0-1.0_wp)/x*f1 - f0 f0 = f1 f1 = f Vl(k) = f enddo elseif ( n>=2 ) then m = msta1(x,200) if ( m<n ) then n = m else m = msta2(x,n,15) endif f = 0.0_wp f2 = 0.0_wp f1 = 1.0d-100 do k = m , 0 , -1 f = 2.0_wp*(v0+k+1.0_wp)/x*f1 - f2 if ( k<=n ) Vl(k) = f f2 = f1 f1 = f enddo cs = 0.0_wp if ( abs(bjv0)>abs(bjv1) ) then cs = bjv0/f else cs = bjv1/f2 endif do k = 0 , n Vl(k) = cs*Vl(k) enddo endif Vl(0) = fac*Vl(0) do j = 1 , n rc = fac*r0 Vl(j) = rc*Vl(j) Dl(j-1) = -0.5_wp*x/(j+v0)*Vl(j) r0 = 2.0_wp*(j+v0+1)/x*r0 enddo Dl(n) = 2.0_wp*(v0+n)*(Vl(n-1)-Vl(n))/x Vm = n + v0 end !***************************************************************************************** !> ! Compute hypergeometric function U(a,b,x) by ! using Gaussian-Legendre integration (n=60) subroutine chguit(a,b,x,Hu,Id) ! Input : a --- Parameter ( a > 0 ) ! b --- Parameter ! x --- Argument ( x > 0 ) ! Output: HU --- U(a,b,z) ! ID --- Estimated number of significant digits real(wp) a , a1 , b , b1 , c , d , f1 , f2 , g , ga , Hu ,& & hu0 , hu1 , hu2 , s , t , t1 , t2 , t3 , t4 real(wp) w , x integer Id , j , k , m dimension t(30) , w(30) data t/.259597723012478d-01 , .778093339495366d-01 , & & .129449135396945d+00 , .180739964873425d+00 , & & .231543551376029d+00 , .281722937423262d+00 , & & .331142848268448d+00 , .379670056576798d+00 , & & .427173741583078d+00 , .473525841761707d+00 , & & .518601400058570d+00 , .562278900753945d+00 , & & .604440597048510d+00 , .644972828489477d+00 , & & .683766327381356d+00 , .720716513355730d+00 , & & .755723775306586d+00 , .788693739932264d+00 , & & .819537526162146d+00 , .848171984785930d+00 , & & .874519922646898d+00 , .898510310810046d+00 , & & .920078476177628d+00 , .939166276116423d+00 , & & .955722255839996d+00 , .969701788765053d+00 , & & .981067201752598d+00 , .989787895222222d+00 , & & .995840525118838d+00 , .999210123227436d+00/ data w/.519078776312206d-01 , .517679431749102d-01 , & & .514884515009810d-01 , .510701560698557d-01 , & & .505141845325094d-01 , .498220356905502d-01 , & & .489955754557568d-01 , .480370318199712d-01 , & & .469489888489122d-01 , .457343797161145d-01 , & & .443964787957872d-01 , .429388928359356d-01 , & & .413655512355848d-01 , .396806954523808d-01 , & & .378888675692434d-01 , .359948980510845d-01 , & & .340038927249464d-01 , .319212190192963d-01 , & & .297524915007890d-01 , .275035567499248d-01 , & & .251804776215213d-01 , .227895169439978d-01 , & & .203371207294572d-01 , .178299010142074d-01 , & & .152746185967848d-01 , .126781664768159d-01 , & & .100475571822880d-01 , .738993116334531d-02 , & & .471272992695363d-02 , .202681196887362d-02/ Id = 9 ! DLMF 13.4.4, integration up to C=12/X a1 = a - 1.0_wp b1 = b - a - 1.0_wp c = 12.0d0/x hu0 = 0.0_wp do m = 10 , 100 , 5 hu1 = 0.0_wp g = 0.5_wp*c/m d = g do j = 1 , m s = 0.0_wp do k = 1 , 30 t1 = d + g*t(k) t2 = d - g*t(k) f1 = exp(-x*t1)*t1**a1*(1.0_wp+t1)**b1 f2 = exp(-x*t2)*t2**a1*(1.0_wp+t2)**b1 s = s + w(k)*(f1+f2) enddo hu1 = hu1 + s*g d = d + 2.0_wp*g enddo if ( abs(1.0_wp-hu0/hu1)<1.0d-9 ) exit hu0 = hu1 enddo call gamma2(a,ga) hu1 = hu1/ga ! DLMF 13.4.4 with substitution t=C/(1-u) ! integration u from 0 to 1, i.e. t from C=12/X to infinity do m = 2 , 10 , 2 hu2 = 0.0_wp g = 0.5_wp/m d = g do j = 1 , m s = 0.0_wp do k = 1 , 30 t1 = d + g*t(k) t2 = d - g*t(k) t3 = c/(1.0_wp-t1) t4 = c/(1.0_wp-t2) f1 = t3*t3/c*exp(-x*t3)*t3**a1*(1.0_wp+t3)**b1 f2 = t4*t4/c*exp(-x*t4)*t4**a1*(1.0_wp+t4)**b1 s = s + w(k)*(f1+f2) enddo hu2 = hu2 + s*g d = d + 2.0_wp*g enddo if ( abs(1.0_wp-hu0/hu2)<1.0d-9 ) exit hu0 = hu2 enddo call gamma2(a,ga) hu2 = hu2/ga Hu = hu1 + hu2 end !***************************************************************************************** !> ! Compute the expansion coefficients of the ! prolate and oblate spheroidal functions ! and joining factors subroutine kmn(m,n,c,Cv,Kd,Df,Dn,Ck1,Ck2) real(wp) c , Ck1 , Ck2 , cs , Cv , Df , Dn , dnp , g0 , & & gk0 , gk1 , gk2 , gk3 , r , r1 , r2 , r3 , r4 , & & r5 , rk real(wp) sa0 , sb0 , su0 , sw , t , tp , u , v , w integer i , ip , j , k , Kd , l , m , n , nm , nm1 , nn dimension u(200) , v(200) , w(200) , Df(200) , Dn(200) , tp(200) ,& & rk(200) nm = 25 + int(0.5*(n-m)+c) nn = nm + m cs = c*c*Kd ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 k = 0 do i = 1 , nn + 3 if ( ip==0 ) k = -2*(i-1) if ( ip==1 ) k = -(2*i-3) gk0 = 2.0_wp*m + k gk1 = (m+k)*(m+k+1.0_wp) gk2 = 2.0_wp*(m+k) - 1.0_wp gk3 = 2.0_wp*(m+k) + 3.0_wp u(i) = gk0*(gk0-1.0_wp)*cs/(gk2*(gk2+2.0_wp)) v(i) = gk1 - Cv + (2.0_wp*(gk1-m*m)-1.0_wp)*cs/(gk2*gk3) w(i) = (k+1.0_wp)*(k+2.0_wp)*cs/((gk2+2.0_wp)*gk3) enddo do k = 1 , m t = v(m+1) do l = 0 , m - k - 1 t = v(m-l) - w(m-l+1)*u(m-l)/t enddo rk(k) = -u(k)/t enddo r = 1.0_wp do k = 1 , m r = r*rk(k) Dn(k) = Df(1)*r enddo tp(nn) = v(nn+1) do k = nn - 1 , m + 1 , -1 tp(k) = v(k+1) - w(k+2)*u(k+1)/tp(k+1) if ( k>m+1 ) rk(k) = -u(k)/tp(k) enddo if ( m==0 ) dnp = Df(1) if ( m/=0 ) dnp = Dn(m) Dn(m+1) = (-1)**ip*dnp*cs/((2.0*m-1.0)*(2.0*m+1.0-4.0*ip)*tp(m+1)) do k = m + 2 , nn Dn(k) = rk(k)*Dn(k-1) enddo r1 = 1.0_wp do j = 1 , (n+m+ip)/2 r1 = r1*(j+0.5_wp*(n+m+ip)) enddo nm1 = (n-m)/2 r = 1.0_wp do j = 1 , 2*m + ip r = r*j enddo su0 = r*Df(1) sw = 0.0_wp do k = 2 , nm r = r*(m+k-1.0)*(m+k+ip-1.5d0)/(k-1.0_wp)/(k+ip-1.5d0) su0 = su0 + r*Df(k) if ( k>nm1 .and. abs((su0-sw)/su0)<1.0d-14 ) exit sw = su0 enddo if ( Kd/=1 ) then r2 = 1.0_wp do j = 1 , m r2 = 2.0_wp*c*r2*j enddo r3 = 1.0_wp do j = 1 , (n-m-ip)/2 r3 = r3*j enddo sa0 = (2.0*(m+ip)+1.0)*r1/(2.0**n*c**ip*r2*r3*Df(1)) Ck1 = sa0*su0 if ( Kd==-1 ) return endif r4 = 1.0_wp do j = 1 , (n-m-ip)/2 r4 = 4.0_wp*r4*j enddo r5 = 1.0_wp do j = 1 , m r5 = r5*(j+m)/c enddo g0 = Dn(m) if ( m==0 ) g0 = Df(1) sb0 = (ip+1.0)*c**(ip+1)/(2.0*ip*(m-2.0)+1.0)/(2.0*m-1.0) Ck2 = (-1)**ip*sb0*r4*r5*g0/r1*su0 end !***************************************************************************************** !> ! Compute the zeros of Laguerre polynomial Ln(x) ! in the interval [0,∞], and the corresponding ! weighting coefficients for Gauss-Laguerre ! integration subroutine lagzo(n,x,w) ! Input : n --- Order of the Laguerre polynomial ! X(n) --- Zeros of the Laguerre polynomial ! W(n) --- Corresponding weighting coefficients real(wp) f0 , f1 , fd , gd , hn , p , pd , pf , q , w , & & wp_ , x , z , z0 integer i , it , j , k , n , nr dimension x(n) , w(n) hn = 1.0_wp/n pf = 0.0_wp pd = 0.0_wp do nr = 1 , n z = hn if ( nr>1 ) z = x(nr-1) + hn*nr**1.27 it = 0 50 it = it + 1 z0 = z p = 1.0_wp do i = 1 , nr - 1 p = p*(z-x(i)) enddo f0 = 1.0_wp f1 = 1.0_wp - z do k = 2 , n pf = ((2.0_wp*k-1.0_wp-z)*f1-(k-1.0_wp)*f0)/k pd = k/z*(pf-f1) f0 = f1 f1 = pf enddo fd = pf/p q = 0.0_wp do i = 1 , nr - 1 wp_ = 1.0_wp do j = 1 , nr - 1 if ( j/=i ) wp_ = wp_*(z-x(j)) enddo q = q + wp_ enddo gd = (pd-q*fd)/p z = z - fd/gd if ( it<=40 .and. abs((z-z0)/z)>1.0d-15 ) goto 50 x(nr) = z w(nr) = 1.0_wp/(z*pd*pd) enddo end !***************************************************************************************** !> ! Compute parabolic cylinder function Vv(x) ! for large argument subroutine vvla(Va,x,Pv) ! Input: x --- Argument ! va --- Order ! Output: PV --- Vv(x) real(wp) a0 , dsl , eps , gl , pdl , Pv , qe , r , & & Va , x , x1 integer k eps = 1.0d-12 qe = exp(0.25*x*x) a0 = abs(x)**(-Va-1.0_wp)*sqrt(2.0_wp/pi)*qe r = 1.0_wp Pv = 1.0_wp do k = 1 , 18 r = 0.5_wp*r*(2.0*k+Va-1.0)*(2.0*k+Va)/(k*x*x) Pv = Pv + r if ( abs(r/Pv)<eps ) exit enddo Pv = a0*Pv if ( x<0.0_wp ) then x1 = -x call dvla(Va,x1,pdl) call gamma2(-Va,gl) dsl = sin(pi*Va)*sin(pi*Va) Pv = dsl*gl/pi*pdl - cos(pi*Va)*Pv endif end !***************************************************************************************** !> ! Compute Bessel functions Jv(z), Yv(z) and their ! derivatives for a complex argument subroutine cjyva(v,z,Vm,Cbj,Cdj,Cby,Cdy) ! Input : z --- Complex argument ! v --- Order of Jv(z) and Yv(z) ! ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) ! Output: CBJ(n) --- Jn+v0(z) ! CDJ(n) --- Jn+v0'(z) ! CBY(n) --- Yn+v0(z) ! CDY(n) --- Yn+v0'(z) ! VM --- Highest order computed implicit none real(wp) a0 , ga , gb , pv0 , pv1 , rp2 , v , v0 , & & vg , vl , Vm , vv , w0 , w1 , wa , ya0 , ya1 , & & yak complex(wp) ca , ca0 , cb , Cbj , Cby , cck , Cdj , Cdy , cec , & & cf , cf0 , cf1 , cf2 , cfac0 , cfac1 , cg0 , cg1 , & & ch0 , ch1 , ch2 complex(wp) ci , cju0 , cju1 , cjv0 , cjv1 , cjvl , cp11 , cp12 , & & cp21 , cp22 , cpz , cqz , cr , cr0 , cr1 , crp , crq , & & cs , cs0 , cs1 complex(wp) csk , cyk , cyl1 , cyl2 , cylk , cyv0 , cyv1 , z , z1 ,& & z2 , zk integer j , k , k0 , l , lb , lb0 , m , n dimension Cbj(0:*) , Cdj(0:*) , Cby(0:*) , Cdy(0:*) rp2 = .63661977236758d0 ci = (0.0_wp,1.0_wp) a0 = abs(z) z1 = z z2 = z*z n = int(v) v0 = v - n pv0 = pi*v0 pv1 = pi*(1.0_wp+v0) if ( a0<1.0d-100 ) then do k = 0 , n Cbj(k) = (0.0_wp,0.0_wp) Cdj(k) = (0.0_wp,0.0_wp) Cby(k) = -(1.0e+300_wp,0.0_wp) Cdy(k) = (1.0e+300_wp,0.0_wp) enddo if ( v0==0.0 ) then Cbj(0) = (1.0_wp,0.0_wp) Cdj(1) = (0.5_wp,0.0_wp) else Cdj(0) = (1.0e+300_wp,0.0_wp) endif Vm = v return endif lb0 = 0.0_wp if ( real(z,wp)<0.0 ) z1 = -z if ( a0<=12.0 ) then do l = 0 , 1 vl = v0 + l cjvl = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25d0*cr*z2/(k*(k+vl)) cjvl = cjvl + cr if ( abs(cr)<abs(cjvl)*1.0d-15 ) exit enddo vg = 1.0_wp + vl call gamma2(vg,ga) ca = (0.5_wp*z1)**vl/ga if ( l==0 ) cjv0 = cjvl*ca if ( l==1 ) cjv1 = cjvl*ca enddo else k0 = 11 if ( a0>=35.0 ) k0 = 10 if ( a0>=50.0 ) k0 = 8 do j = 0 , 1 vv = 4.0_wp*(j+v0)*(j+v0) cpz = (1.0_wp,0.0_wp) crp = (1.0_wp,0.0_wp) do k = 1 , k0 crp = -0.78125d-2*crp*(vv-(4.0*k-3.0)**2.0) & & *(vv-(4.0*k-1.0)**2.0)/(k*(2.0*k-1.0)*z2) cpz = cpz + crp enddo cqz = (1.0_wp,0.0_wp) crq = (1.0_wp,0.0_wp) do k = 1 , k0 crq = -0.78125d-2*crq*(vv-(4.0*k-1.0)**2.0) & & *(vv-(4.0*k+1.0)**2.0)/(k*(2.0*k+1.0)*z2) cqz = cqz + crq enddo cqz = 0.125d0*(vv-1.0)*cqz/z1 zk = z1 - (0.5_wp*(j+v0)+0.25d0)*pi ca0 = sqrt(rp2/z1) cck = cos(zk) csk = sin(zk) if ( j==0 ) then cjv0 = ca0*(cpz*cck-cqz*csk) cyv0 = ca0*(cpz*csk+cqz*cck) elseif ( j==1 ) then cjv1 = ca0*(cpz*cck-cqz*csk) cyv1 = ca0*(cpz*csk+cqz*cck) endif enddo endif if ( a0<=12.0 ) then if ( v0/=0.0 ) then do l = 0 , 1 vl = v0 + l cjvl = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25d0*cr*z2/(k*(k-vl)) cjvl = cjvl + cr if ( abs(cr)<abs(cjvl)*1.0d-15 ) exit enddo vg = 1.0_wp - vl call gamma2(vg,gb) cb = (2.0_wp/z1)**vl/gb if ( l==0 ) cju0 = cjvl*cb if ( l==1 ) cju1 = cjvl*cb enddo cyv0 = (cjv0*cos(pv0)-cju0)/sin(pv0) cyv1 = (cjv1*cos(pv1)-cju1)/sin(pv1) else cec = log(z1/2.0_wp) + .5772156649015329d0 cs0 = (0.0_wp,0.0_wp) w0 = 0.0_wp cr0 = (1.0_wp,0.0_wp) do k = 1 , 30 w0 = w0 + 1.0_wp/k cr0 = -0.25d0*cr0/(k*k)*z2 cs0 = cs0 + cr0*w0 enddo cyv0 = rp2*(cec*cjv0-cs0) cs1 = (1.0_wp,0.0_wp) w1 = 0.0_wp cr1 = (1.0_wp,0.0_wp) do k = 1 , 30 w1 = w1 + 1.0_wp/k cr1 = -0.25d0*cr1/(k*(k+1))*z2 cs1 = cs1 + cr1*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) enddo cyv1 = rp2*(cec*cjv1-1.0_wp/z1-0.25d0*z1*cs1) endif endif if ( real(z,wp)<0.0_wp ) then cfac0 = exp(pv0*ci) cfac1 = exp(pv1*ci) if ( aimag(z)<0.0_wp ) then cyv0 = cfac0*cyv0 - 2.0_wp*ci*cos(pv0)*cjv0 cyv1 = cfac1*cyv1 - 2.0_wp*ci*cos(pv1)*cjv1 cjv0 = cjv0/cfac0 cjv1 = cjv1/cfac1 elseif ( aimag(z)>0.0_wp ) then cyv0 = cyv0/cfac0 + 2.0_wp*ci*cos(pv0)*cjv0 cyv1 = cyv1/cfac1 + 2.0_wp*ci*cos(pv1)*cjv1 cjv0 = cfac0*cjv0 cjv1 = cfac1*cjv1 endif endif Cbj(0) = cjv0 Cbj(1) = cjv1 if ( n>=2 .and. n<=int(0.25*a0) ) then cf0 = cjv0 cf1 = cjv1 do k = 2 , n cf = 2.0_wp*(k+v0-1.0_wp)/z*cf1 - cf0 Cbj(k) = cf cf0 = cf1 cf1 = cf enddo elseif ( n>=2 ) then m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0d-100,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z*cf1 - cf2 if ( k<=n ) Cbj(k) = cf cf2 = cf1 cf1 = cf enddo if ( abs(cjv0)>abs(cjv1) ) cs = cjv0/cf if ( abs(cjv0)<=abs(cjv1) ) cs = cjv1/cf2 do k = 0 , n Cbj(k) = cs*Cbj(k) enddo endif Cdj(0) = v0/z*Cbj(0) - Cbj(1) do k = 1 , n Cdj(k) = -(k+v0)/z*Cbj(k) + Cbj(k-1) enddo Cby(0) = cyv0 Cby(1) = cyv1 ya0 = abs(cyv0) lb = 0 cg0 = cyv0 cg1 = cyv1 do k = 2 , n cyk = 2.0_wp*(v0+k-1.0_wp)/z*cg1 - cg0 if ( abs(cyk)<=1.0d+290 ) then yak = abs(cyk) ya1 = abs(cg0) if ( yak<ya0 .and. yak<ya1 ) lb = k Cby(k) = cyk cg0 = cg1 cg1 = cyk endif enddo if ( lb>4 .and. aimag(z)/=0.0_wp ) then 50 if ( lb/=lb0 ) then ch2 = (1.0_wp,0.0_wp) ch1 = (0.0_wp,0.0_wp) lb0 = lb do k = lb , 1 , -1 ch0 = 2.0_wp*(k+v0)/z*ch1 - ch2 ch2 = ch1 ch1 = ch0 enddo cp12 = ch0 cp22 = ch2 ch2 = (0.0_wp,0.0_wp) ch1 = (1.0_wp,0.0_wp) do k = lb , 1 , -1 ch0 = 2.0_wp*(k+v0)/z*ch1 - ch2 ch2 = ch1 ch1 = ch0 enddo cp11 = ch0 cp21 = ch2 if ( lb==n ) Cbj(lb+1) = 2.0_wp*(lb+v0)/z*Cbj(lb) - Cbj(lb-1) if ( abs(Cbj(0))>abs(Cbj(1)) ) then Cby(lb+1) = (Cbj(lb+1)*cyv0-2.0_wp*cp11/(pi*z))/Cbj(0) Cby(lb) = (Cbj(lb)*cyv0+2.0_wp*cp12/(pi*z))/Cbj(0) else Cby(lb+1) = (Cbj(lb+1)*cyv1-2.0_wp*cp21/(pi*z))/Cbj(1) Cby(lb) = (Cbj(lb)*cyv1+2.0_wp*cp22/(pi*z))/Cbj(1) endif cyl2 = Cby(lb+1) cyl1 = Cby(lb) do k = lb - 1 , 0 , -1 cylk = 2.0_wp*(k+v0+1.0_wp)/z*cyl1 - cyl2 Cby(k) = cylk cyl2 = cyl1 cyl1 = cylk enddo cyl1 = Cby(lb) cyl2 = Cby(lb+1) do k = lb + 1 , n - 1 cylk = 2.0_wp*(k+v0)/z*cyl2 - cyl1 Cby(k+1) = cylk cyl1 = cyl2 cyl2 = cylk enddo do k = 2 , n wa = abs(Cby(k)) if ( wa<abs(Cby(k-1)) ) lb = k enddo goto 50 endif endif Cdy(0) = v0/z*Cby(0) - Cby(1) do k = 1 , n Cdy(k) = Cby(k-1) - (k+v0)/z*Cby(k) enddo Vm = n + v0 end !***************************************************************************************** !> ! Compute Bessel functions Jv(z), Yv(z) and their ! derivatives for a complex argument subroutine cjyvb(v,z,Vm,Cbj,Cdj,Cby,Cdy) ! Input : z --- Complex argument ! v --- Order of Jv(z) and Yv(z) ! ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) ! Output: CBJ(n) --- Jn+v0(z) ! CDJ(n) --- Jn+v0'(z) ! CBY(n) --- Yn+v0(z) ! CDY(n) --- Yn+v0'(z) ! VM --- Highest order computed real(wp) a0 , ga , gb , pv0 , rp2 , v , v0 , vg , & & Vm , vv , w0 complex(wp) ca , ca0 , cb , Cbj , Cby , cck , Cdj , Cdy , cec , & & cf , cf1 , cf2 , cfac0 , ci , cju0 , cjv0 , cjvn , & & cpz , cqz , cr complex(wp) cr0 , crp , crq , cs , cs0 , csk , cyv0 , cyy , z , & & z1 , z2 , zk integer k , k0 , m , n dimension Cbj(0:*) , Cdj(0:*) , Cby(0:*) , Cdy(0:*) rp2 = .63661977236758d0 ci = (0.0_wp,1.0_wp) a0 = abs(z) z1 = z z2 = z*z n = int(v) v0 = v - n pv0 = pi*v0 if ( a0<1.0d-100 ) then do k = 0 , n Cbj(k) = (0.0_wp,0.0_wp) Cdj(k) = (0.0_wp,0.0_wp) Cby(k) = -(1.0e+300_wp,0.0_wp) Cdy(k) = (1.0e+300_wp,0.0_wp) enddo if ( v0==0.0 ) then Cbj(0) = (1.0_wp,0.0_wp) Cdj(1) = (0.5_wp,0.0_wp) else Cdj(0) = (1.0e+300_wp,0.0_wp) endif Vm = v return endif if ( real(z,wp)<0.0_wp ) z1 = -z if ( a0<=12.0 ) then cjv0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25d0*cr*z2/(k*(k+v0)) cjv0 = cjv0 + cr if ( abs(cr)<abs(cjv0)*1.0d-15 ) exit enddo vg = 1.0_wp + v0 call gamma2(vg,ga) ca = (0.5_wp*z1)**v0/ga cjv0 = cjv0*ca else k0 = 11 if ( a0>=35.0 ) k0 = 10 if ( a0>=50.0 ) k0 = 8 vv = 4.0_wp*v0*v0 cpz = (1.0_wp,0.0_wp) crp = (1.0_wp,0.0_wp) do k = 1 , k0 crp = -0.78125d-2*crp*(vv-(4.0*k-3.0)**2.0) & & *(vv-(4.0*k-1.0)**2.0)/(k*(2.0*k-1.0)*z2) cpz = cpz + crp enddo cqz = (1.0_wp,0.0_wp) crq = (1.0_wp,0.0_wp) do k = 1 , k0 crq = -0.78125d-2*crq*(vv-(4.0*k-1.0)**2.0) & & *(vv-(4.0*k+1.0)**2.0)/(k*(2.0*k+1.0)*z2) cqz = cqz + crq enddo cqz = 0.125d0*(vv-1.0)*cqz/z1 zk = z1 - (0.5_wp*v0+0.25d0)*pi ca0 = sqrt(rp2/z1) cck = cos(zk) csk = sin(zk) cjv0 = ca0*(cpz*cck-cqz*csk) cyv0 = ca0*(cpz*csk+cqz*cck) endif if ( a0<=12.0 ) then if ( v0/=0.0 ) then cjvn = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25d0*cr*z2/(k*(k-v0)) cjvn = cjvn + cr if ( abs(cr)<abs(cjvn)*1.0d-15 ) exit enddo vg = 1.0_wp - v0 call gamma2(vg,gb) cb = (2.0_wp/z1)**v0/gb cju0 = cjvn*cb cyv0 = (cjv0*cos(pv0)-cju0)/sin(pv0) else cec = log(z1/2.0_wp) + .5772156649015329d0 cs0 = (0.0_wp,0.0_wp) w0 = 0.0_wp cr0 = (1.0_wp,0.0_wp) do k = 1 , 30 w0 = w0 + 1.0_wp/k cr0 = -0.25d0*cr0/(k*k)*z2 cs0 = cs0 + cr0*w0 enddo cyv0 = rp2*(cec*cjv0-cs0) endif endif if ( n==0 ) n = 1 m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0d-100,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z1*cf1 - cf2 if ( k<=n ) Cbj(k) = cf cf2 = cf1 cf1 = cf enddo cs = cjv0/cf do k = 0 , n Cbj(k) = cs*Cbj(k) enddo if ( real(z,wp)<0.0_wp ) then cfac0 = exp(pv0*ci) if ( aimag(z)<0.0_wp ) then cyv0 = cfac0*cyv0 - 2.0_wp*ci*cos(pv0)*cjv0 elseif ( aimag(z)>0.0_wp ) then cyv0 = cyv0/cfac0 + 2.0_wp*ci*cos(pv0)*cjv0 endif do k = 0 , n if ( aimag(z)<0.0_wp ) then Cbj(k) = exp(-pi*(k+v0)*ci)*Cbj(k) elseif ( aimag(z)>0.0_wp ) then Cbj(k) = exp(pi*(k+v0)*ci)*Cbj(k) endif enddo z1 = z1 endif Cby(0) = cyv0 do k = 1 , n cyy = (Cbj(k)*Cby(k-1)-2.0_wp/(pi*z))/Cbj(k-1) Cby(k) = cyy enddo Cdj(0) = v0/z*Cbj(0) - Cbj(1) do k = 1 , n Cdj(k) = -(k+v0)/z*Cbj(k) + Cbj(k-1) enddo Cdy(0) = v0/z*Cby(0) - Cby(1) do k = 1 , n Cdy(k) = Cby(k-1) - (k+v0)/z*Cby(k) enddo Vm = n + v0 end !***************************************************************************************** !> ! Compute Bessel functions J0(x), J1(x), Y0(x), ! Y1(x), and their derivatives subroutine jy01a(x,Bj0,Dj0,Bj1,Dj1,By0,Dy0,By1,Dy1) ! Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) ! Output: BJ0 --- J0(x) ! DJ0 --- J0'(x) ! BJ1 --- J1(x) ! DJ1 --- J1'(x) ! BY0 --- Y0(x) ! DY0 --- Y0'(x) ! BY1 --- Y1(x) ! DY1 --- Y1'(x) real(wp) a , a1 , b , b1 , Bj0 , Bj1 , By0 , By1 , cs0 , & & cs1 , cu , Dj0 , Dj1 , Dy0 , Dy1 , ec , p0 , p1 ,& & q0 real(wp) q1 , r , r0 , r1 , rp2 , t1 , t2 , w0 , w1 , x , & & x2 integer k , k0 dimension a(12) , b(12) , a1(12) , b1(12) rp2 = 0.63661977236758d0 x2 = x*x if ( x==0.0_wp ) then Bj0 = 1.0_wp Bj1 = 0.0_wp Dj0 = 0.0_wp Dj1 = 0.5_wp By0 = -1.0e+300_wp By1 = -1.0e+300_wp Dy0 = 1.0e+300_wp Dy1 = 1.0e+300_wp return endif if ( x<=12.0d0 ) then Bj0 = 1.0_wp r = 1.0_wp do k = 1 , 30 r = -0.25d0*r*x2/(k*k) Bj0 = Bj0 + r if ( abs(r)<abs(Bj0)*1.0d-15 ) exit enddo Bj1 = 1.0_wp r = 1.0_wp do k = 1 , 30 r = -0.25d0*r*x2/(k*(k+1.0_wp)) Bj1 = Bj1 + r if ( abs(r)<abs(Bj1)*1.0d-15 ) exit enddo Bj1 = 0.5_wp*x*Bj1 ec = log(x/2.0_wp) + 0.5772156649015329d0 cs0 = 0.0_wp w0 = 0.0_wp r0 = 1.0_wp do k = 1 , 30 w0 = w0 + 1.0_wp/k r0 = -0.25d0*r0/(k*k)*x2 r = r0*w0 cs0 = cs0 + r if ( abs(r)<abs(cs0)*1.0d-15 ) exit enddo By0 = rp2*(ec*Bj0-cs0) cs1 = 1.0_wp w1 = 0.0_wp r1 = 1.0_wp do k = 1 , 30 w1 = w1 + 1.0_wp/k r1 = -0.25d0*r1/(k*(k+1))*x2 r = r1*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) cs1 = cs1 + r if ( abs(r)<abs(cs1)*1.0d-15 ) exit enddo By1 = rp2*(ec*Bj1-1.0_wp/x-0.25d0*x*cs1) else data a/ - .7031250000000000d-01 , .1121520996093750d+00 , & & -.5725014209747314d+00 , .6074042001273483d+01 , & & -.1100171402692467d+03 , .3038090510922384d+04 , & & -.1188384262567832d+06 , .6252951493434797d+07 , & & -.4259392165047669d+09 , .3646840080706556d+11 , & & -.3833534661393944d+13 , .4854014686852901d+15/ data b/.7324218750000000d-01 , -.2271080017089844d+00 , & & .1727727502584457d+01 , -.2438052969955606d+02 , & & .5513358961220206d+03 , -.1825775547429318d+05 , & & .8328593040162893d+06 , -.5006958953198893d+08 , & & .3836255180230433d+10 , -.3649010818849833d+12 , & & .4218971570284096d+14 , -.5827244631566907d+16/ data a1/.1171875000000000d+00 , -.1441955566406250d+00 , & & .6765925884246826d+00 , -.6883914268109947d+01 , & & .1215978918765359d+03 , -.3302272294480852d+04 , & & .1276412726461746d+06 , -.6656367718817688d+07 , & & .4502786003050393d+09 , -.3833857520742790d+11 , & & .4011838599133198d+13 , -.5060568503314727d+15/ data b1/ - .1025390625000000d+00 , .2775764465332031d+00 , & & -.1993531733751297d+01 , .2724882731126854d+02 , & & -.6038440767050702d+03 , .1971837591223663d+05 , & & -.8902978767070678d+06 , .5310411010968522d+08 , & & -.4043620325107754d+10 , .3827011346598605d+12 , & & -.4406481417852278d+14 , .6065091351222699d+16/ k0 = 12 if ( x>=35.0 ) k0 = 10 if ( x>=50.0 ) k0 = 8 t1 = x - 0.25d0*pi p0 = 1.0_wp q0 = -0.125d0/x do k = 1 , k0 p0 = p0 + a(k)*x**(-2*k) q0 = q0 + b(k)*x**(-2*k-1) enddo cu = sqrt(rp2/x) Bj0 = cu*(p0*cos(t1)-q0*sin(t1)) By0 = cu*(p0*sin(t1)+q0*cos(t1)) t2 = x - 0.75d0*pi p1 = 1.0_wp q1 = 0.375d0/x do k = 1 , k0 p1 = p1 + a1(k)*x**(-2*k) q1 = q1 + b1(k)*x**(-2*k-1) enddo cu = sqrt(rp2/x) Bj1 = cu*(p1*cos(t2)-q1*sin(t2)) By1 = cu*(p1*sin(t2)+q1*cos(t2)) endif Dj0 = -Bj1 Dj1 = Bj0 - Bj1/x Dy0 = -By1 Dy1 = By0 - By1/x end !***************************************************************************************** !> ! Compute the incomplete gamma function ! r(a,x), Г(a,x) and P(a,x) subroutine incog(a,x,Gin,Gim,Gip,Isfer) ! Input : a --- Parameter ( a ≤ 170 ) ! x --- Argument ! Output: GIN --- r(a,x) ! GIM --- Г(a,x) ! GIP --- P(a,x) ! ISFER --- Error flag real(wp) a , ga , Gim , Gin , Gip , r , s , t0 , x , xam integer Isfer , k Isfer = 0 xam = -x + a*log(x) if ( xam>700.0 .or. a>170.0 ) then Isfer = 6 return endif if ( x==0.0 ) then Gin = 0.0 call gamma2(a,ga) Gim = ga Gip = 0.0 elseif ( x<=1.0+a ) then s = 1.0_wp/a r = s do k = 1 , 60 r = r*x/(a+k) s = s + r if ( abs(r/s)<1.0d-15 ) exit enddo Gin = exp(xam)*s call gamma2(a,ga) Gip = Gin/ga Gim = ga - Gin elseif ( x>1.0+a ) then t0 = 0.0_wp do k = 60 , 1 , -1 t0 = (k-a)/(1.0_wp+k/(x+t0)) enddo Gim = exp(xam)/(x+t0) call gamma2(a,ga) Gin = ga - Gim Gip = 1.0_wp - Gim/ga endif end !***************************************************************************************** !> ! Integrate Bessel functions I0(t) and K0(t) ! with respect to t from 0 to x subroutine itikb(x,Ti,Tk) ! Input : x --- Upper limit of the integral ( x ≥ 0 ) ! Output: TI --- Integration of I0(t) from 0 to x ! TK --- Integration of K0(t) from 0 to x real(wp) t , t1 , Ti , Tk , x if ( x==0.0_wp ) then Ti = 0.0_wp elseif ( x<5.0_wp ) then t1 = x/5.0_wp t = t1*t1 Ti = ((((((((.59434d-3*t+.4500642d-2)*t+.044686921d0)*t+ & & .300704878d0)*t+1.471860153d0)*t+4.844024624d0) & & *t+9.765629849d0)*t+10.416666367d0)*t+5.0_wp)*t1 elseif ( x>=5.0 .and. x<=8.0_wp ) then t = 5.0_wp/x Ti = (((-.015166d0*t-.0202292d0)*t+.1294122d0)*t-.0302912d0) & & *t + .4161224d0 Ti = Ti*exp(x)/sqrt(x) else t = 8.0_wp/x Ti = (((((-.0073995d0*t+.017744d0)*t-.0114858d0)*t+.55956d-2) & & *t+.59191d-2)*t+.0311734d0)*t + .3989423d0 Ti = Ti*exp(x)/sqrt(x) endif if ( x==0.0_wp ) then Tk = 0.0_wp elseif ( x<=2.0_wp ) then t1 = x/2.0_wp t = t1*t1 Tk = ((((((.116d-5*t+.2069d-4)*t+.62664d-3)*t+.01110118d0)*t+ & & .11227902d0)*t+.50407836d0)*t+.84556868d0)*t1 Tk = Tk - log(x/2.0_wp)*Ti elseif ( x>2.0 .and. x<=4.0_wp ) then t = 2.0_wp/x Tk = (((.0160395d0*t-.0781715d0)*t+.185984d0)*t-.3584641d0) & & *t + 1.2494934d0 Tk = pi/2.0_wp - Tk*exp(-x)/sqrt(x) elseif ( x>4.0 .and. x<=7.0_wp ) then t = 4.0_wp/x Tk = (((((.37128d-2*t-.0158449d0)*t+.0320504d0)*t-.0481455d0) & & *t+.0787284d0)*t-.1958273d0)*t + 1.2533141d0 Tk = pi/2.0_wp - Tk*exp(-x)/sqrt(x) else t = 7.0_wp/x Tk = (((((.33934d-3*t-.163271d-2)*t+.417454d-2)*t-.933944d-2) & & *t+.02576646d0)*t-.11190289d0)*t + 1.25331414d0 Tk = pi/2.0_wp - Tk*exp(-x)/sqrt(x) endif end !***************************************************************************************** !> ! Integrate modified Bessel functions I0(t) and ! K0(t) with respect to t from 0 to x subroutine itika(x,Ti,Tk) ! Input : x --- Upper limit of the integral ( x ≥ 0 ) ! Output: TI --- Integration of I0(t) from 0 to x ! TK --- Integration of K0(t) from 0 to x real(wp) a , b1 , b2 , e0 , el , r , rc1 , rc2 , rs ,& & Ti , Tk , tw , x , x2 integer k dimension a(10) el = .5772156649015329d0 data a/.625d0 , 1.0078125d0 , 2.5927734375d0 , 9.1868591308594d0 ,& & 4.1567974090576d+1 , 2.2919635891914d+2 , 1.491504060477d+3 ,& & 1.1192354495579d+4 , 9.515939374212d+4 , 9.0412425769041d+5/ if ( x==0.0_wp ) then Ti = 0.0_wp Tk = 0.0_wp return elseif ( x<20.0d0 ) then x2 = x*x Ti = 1.0_wp r = 1.0_wp do k = 1 , 50 r = .25d0*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 Ti = Ti + r if ( abs(r/Ti)<1.0d-12 ) exit enddo Ti = Ti*x else x2 = 0.0_wp Ti = 1.0_wp r = 1.0_wp do k = 1 , 10 r = r/x Ti = Ti + a(k)*r enddo rc1 = 1.0_wp/sqrt(2.0_wp*pi*x) Ti = rc1*exp(x)*Ti endif if ( x<12.0d0 ) then e0 = el + log(x/2.0_wp) b1 = 1.0_wp - e0 b2 = 0.0_wp rs = 0.0_wp r = 1.0_wp tw = 0.0_wp do k = 1 , 50 r = .25d0*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 b1 = b1 + r*(1.0_wp/(2*k+1)-e0) rs = rs + 1.0_wp/k b2 = b2 + r*rs Tk = b1 + b2 if ( abs((Tk-tw)/Tk)<1.0d-12 ) exit tw = Tk enddo Tk = Tk*x else Tk = 1.0_wp r = 1.0_wp do k = 1 , 10 r = -r/x Tk = Tk + a(k)*r enddo rc2 = sqrt(pi/(2.0_wp*x)) Tk = pi/2.0_wp - rc2*Tk*exp(-x) endif end !***************************************************************************************** !> ! Compute Bessel functions Jv(x) and Yv(x) ! and their derivatives subroutine jyv(v,x,Vm,Bj,Dj,By,Dy) ! Input : x --- Argument of Jv(x) and Yv(x) ! v --- Order of Jv(x) and Yv(x) ! ( v = n+v0, 0 ≤ v0 < 1, n = 0,1,2,... ) ! Output: BJ(n) --- Jn+v0(x) ! DJ(n) --- Jn+v0'(x) ! BY(n) --- Yn+v0(x) ! DY(n) --- Yn+v0'(x) ! VM --- Highest order computed real(wp) a , a0 , b , Bj , bju0 , bju1 , bjv0 , bjv1 , & & bjvl , By , byv0 , byv1 , byvk , ck , cs , cs0 , & & cs1 , Dj , Dy , ec real(wp) el , f , f0 , f1 , f2 , ga , gb , pv0 , & & pv1 , px , qx , r , r0 , r1 , rp , rp2 , rq , & & sk , v real(wp) v0 , vg , vl , Vm , vv , w0 , w1 , x , x2 , xk integer j , k , k0 , l , m , n dimension Bj(0:*) , Dj(0:*) , By(0:*) , Dy(0:*) el = .5772156649015329d0 rp2 = .63661977236758d0 x2 = x*x n = int(v) v0 = v - n if ( x<1.0d-100 ) then do k = 0 , n Bj(k) = 0.0_wp Dj(k) = 0.0_wp By(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo if ( v0==0.0 ) then Bj(0) = 1.0_wp Dj(1) = 0.5_wp else Dj(0) = 1.0e+300_wp endif Vm = v return endif bjv0 = 0.0_wp bjv1 = 0.0_wp byv0 = 0.0_wp byv1 = 0.0_wp if ( x<=12.0 ) then do l = 0 , 1 vl = v0 + l bjvl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25d0*r*x2/(k*(k+vl)) bjvl = bjvl + r if ( abs(r)<abs(bjvl)*1.0d-15 ) exit enddo vg = 1.0_wp + vl call gamma2(vg,ga) a = (0.5_wp*x)**vl/ga if ( l==0 ) bjv0 = bjvl*a if ( l==1 ) bjv1 = bjvl*a enddo else k0 = 11 if ( x>=35.0 ) k0 = 10 if ( x>=50.0 ) k0 = 8 do j = 0 , 1 vv = 4.0_wp*(j+v0)*(j+v0) px = 1.0_wp rp = 1.0_wp do k = 1 , k0 rp = -0.78125d-2*rp*(vv-(4.0*k-3.0)**2.0) & & *(vv-(4.0*k-1.0)**2.0)/(k*(2.0*k-1.0)*x2) px = px + rp enddo qx = 1.0_wp rq = 1.0_wp do k = 1 , k0 rq = -0.78125d-2*rq*(vv-(4.0*k-1.0)**2.0) & & *(vv-(4.0*k+1.0)**2.0)/(k*(2.0*k+1.0)*x2) qx = qx + rq enddo qx = 0.125d0*(vv-1.0)*qx/x xk = x - (0.5_wp*(j+v0)+0.25d0)*pi a0 = sqrt(rp2/x) ck = cos(xk) sk = sin(xk) if ( j==0 ) then bjv0 = a0*(px*ck-qx*sk) byv0 = a0*(px*sk+qx*ck) elseif ( j==1 ) then bjv1 = a0*(px*ck-qx*sk) byv1 = a0*(px*sk+qx*ck) endif enddo endif Bj(0) = bjv0 Bj(1) = bjv1 Dj(0) = v0/x*Bj(0) - Bj(1) Dj(1) = -(1.0_wp+v0)/x*Bj(1) + Bj(0) if ( n>=2 .and. n<=int(0.9*x) ) then f0 = bjv0 f1 = bjv1 do k = 2 , n f = 2.0_wp*(k+v0-1.0_wp)/x*f1 - f0 Bj(k) = f f0 = f1 f1 = f enddo elseif ( n>=2 ) then m = msta1(x,200) if ( m<n ) then n = m else m = msta2(x,n,15) endif f = 0.0_wp f2 = 0.0_wp f1 = 1.0d-100 do k = m , 0 , -1 f = 2.0_wp*(v0+k+1.0_wp)/x*f1 - f2 if ( k<=n ) Bj(k) = f f2 = f1 f1 = f enddo if ( abs(bjv0)>abs(bjv1) ) then cs = bjv0/f else cs = bjv1/f2 endif do k = 0 , n Bj(k) = cs*Bj(k) enddo endif do k = 2 , n Dj(k) = -(k+v0)/x*Bj(k) + Bj(k-1) enddo if ( x<=12.0d0 ) then if ( v0/=0.0 ) then bju0 = 0.0_wp bju1 = 0.0_wp do l = 0 , 1 vl = v0 + l bjvl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25d0*r*x2/(k*(k-vl)) bjvl = bjvl + r if ( abs(r)<abs(bjvl)*1.0d-15 ) exit enddo vg = 1.0_wp - vl call gamma2(vg,gb) b = (2.0_wp/x)**vl/gb if ( l==0 ) bju0 = bjvl*b if ( l==1 ) bju1 = bjvl*b enddo pv0 = pi*v0 pv1 = pi*(1.0_wp+v0) byv0 = (bjv0*cos(pv0)-bju0)/sin(pv0) byv1 = (bjv1*cos(pv1)-bju1)/sin(pv1) else ec = log(x/2.0_wp) + el cs0 = 0.0_wp w0 = 0.0_wp r0 = 1.0_wp do k = 1 , 30 w0 = w0 + 1.0_wp/k r0 = -0.25d0*r0/(k*k)*x2 cs0 = cs0 + r0*w0 enddo byv0 = rp2*(ec*bjv0-cs0) cs1 = 1.0_wp w1 = 0.0_wp r1 = 1.0_wp do k = 1 , 30 w1 = w1 + 1.0_wp/k r1 = -0.25d0*r1/(k*(k+1))*x2 cs1 = cs1 + r1*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) enddo byv1 = rp2*(ec*bjv1-1.0_wp/x-0.25d0*x*cs1) endif endif By(0) = byv0 By(1) = byv1 do k = 2 , n byvk = 2.0_wp*(v0+k-1.0_wp)/x*byv1 - byv0 By(k) = byvk byv0 = byv1 byv1 = byvk enddo Dy(0) = v0/x*By(0) - By(1) do k = 1 , n Dy(k) = -(k+v0)/x*By(k) + By(k-1) enddo Vm = n + v0 end !***************************************************************************************** !> ! Compute Bessel functions Jn(x), Yn(x) and ! their derivatives subroutine jynb(n,x,Nm,Bj,Dj,By,Dy) ! Input : x --- Argument of Jn(x) and Yn(x) ( x ≥ 0 ) ! n --- Order of Jn(x) and Yn(x) ! Output: BJ(n) --- Jn(x) ! DJ(n) --- Jn'(x) ! BY(n) --- Yn(x) ! DY(n) --- Yn'(x) ! NM --- Highest order computed ! Routines called: ! JYNBH to calculate the Jn and Yn real(wp) Bj , By , Dj , Dy , x integer k , n , Nm dimension Bj(0:n) , Dj(0:n) , By(0:n) , Dy(0:n) call jynbh(n,0,x,Nm,Bj,By) ! Compute derivatives by differentiation formulas if ( x<1.0d-100 ) then do k = 0 , n Dj(k) = 0.0_wp Dy(k) = 1.0e+300_wp enddo Dj(1) = 0.5_wp else Dj(0) = -Bj(1) do k = 1 , Nm Dj(k) = Bj(k-1) - k/x*Bj(k) enddo Dy(0) = -By(1) do k = 1 , Nm Dy(k) = By(k-1) - k*By(k)/x enddo endif end !***************************************************************************************** !> ! Compute Bessel functions Jn(x), Yn(x) subroutine jynbh(n,Nmin,x,Nm,Bj,By) ! Input : x --- Argument of Jn(x) and Yn(x) ( x ≥ 0 ) ! n --- Highest order of Jn(x) and Yn(x) computed ( n ≥ 0 ) ! nmin -- Lowest order computed ( nmin ≥ 0 ) ! Output: BJ(n-NMIN) --- Jn(x) ; if indexing starts at 0 ! BY(n-NMIN) --- Yn(x) ; if indexing starts at 0 ! NM --- Highest order computed real(wp) a , a1 , b , b1 , Bj , bj0 , bj1 , bjk , bs , & & By , by0 , by1 , byk , cu , ec , f , f1 , f2 , & & p0 , p1 real(wp) q0 , q1 , r2p , s0 , su , sv , t1 , t2 , x integer k , ky , m , n , Nm , Nmin dimension Bj(0:n-Nmin) , By(0:n-Nmin) , a(4) , b(4) , a1(4) , & & b1(4) r2p = .63661977236758d0 Nm = n if ( x<1.0d-100 ) then do k = Nmin , n Bj(k-Nmin) = 0.0_wp By(k-Nmin) = -1.0e+300_wp enddo if ( Nmin==0 ) Bj(0) = 1.0_wp return endif if ( x<=300.0 .or. n>int(0.9*x) ) then ! Backward recurrence for Jn if ( n==0 ) Nm = 1 m = msta1(x,200) if ( m<Nm ) then Nm = m else m = msta2(x,Nm,15) endif bs = 0.0_wp su = 0.0_wp sv = 0.0_wp f2 = 0.0_wp f1 = 1.0d-100 f = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)/x*f1 - f2 if ( k<=Nm .and. k>=Nmin ) Bj(k-Nmin) = f if ( k==2*int(k/2) .and. k/=0 ) then bs = bs + 2.0_wp*f su = su + (-1)**(k/2)*f/k elseif ( k>1 ) then sv = sv + (-1)**(k/2)*k/(k*k-1.0_wp)*f endif f2 = f1 f1 = f enddo s0 = bs + f do k = Nmin , Nm Bj(k-Nmin) = Bj(k-Nmin)/s0 enddo ! Estimates for Yn at start of recurrence bj0 = f1/s0 bj1 = f2/s0 ec = log(x/2.0_wp) + 0.5772156649015329d0 by0 = r2p*(ec*bj0-4.0_wp*su/s0) by1 = r2p*((ec-1.0_wp)*bj1-bj0/x-4.0_wp*sv/s0) if ( 0>=Nmin ) By(0-Nmin) = by0 if ( 1>=Nmin ) By(1-Nmin) = by1 ky = 2 else ! Hankel expansion data a/ - .7031250000000000d-01 , .1121520996093750d+00 , & & -.5725014209747314d+00 , .6074042001273483d+01/ data b/.7324218750000000d-01 , -.2271080017089844d+00 , & & .1727727502584457d+01 , -.2438052969955606d+02/ data a1/.1171875000000000d+00 , -.1441955566406250d+00 , & & .6765925884246826d+00 , -.6883914268109947d+01/ data b1/ - .1025390625000000d+00 , .2775764465332031d+00 , & & -.1993531733751297d+01 , .2724882731126854d+02/ t1 = x - 0.25d0*pi p0 = 1.0_wp q0 = -0.125d0/x do k = 1 , 4 p0 = p0 + a(k)*x**(-2*k) q0 = q0 + b(k)*x**(-2*k-1) enddo cu = sqrt(r2p/x) bj0 = cu*(p0*cos(t1)-q0*sin(t1)) by0 = cu*(p0*sin(t1)+q0*cos(t1)) if ( 0>=Nmin ) Bj(0-Nmin) = bj0 if ( 0>=Nmin ) By(0-Nmin) = by0 t2 = x - 0.75d0*pi p1 = 1.0_wp q1 = 0.375d0/x do k = 1 , 4 p1 = p1 + a1(k)*x**(-2*k) q1 = q1 + b1(k)*x**(-2*k-1) enddo bj1 = cu*(p1*cos(t2)-q1*sin(t2)) by1 = cu*(p1*sin(t2)+q1*cos(t2)) if ( 1>=Nmin ) Bj(1-Nmin) = bj1 if ( 1>=Nmin ) By(1-Nmin) = by1 do k = 2 , Nm bjk = 2.0_wp*(k-1.0_wp)/x*bj1 - bj0 if ( k>=Nmin ) Bj(k-Nmin) = bjk bj0 = bj1 bj1 = bjk enddo ky = 2 endif ! Forward recurrence for Yn do k = ky , Nm byk = 2.0_wp*(k-1.0_wp)*by1/x - by0 if ( k>=Nmin ) By(k-Nmin) = byk by0 = by1 by1 = byk enddo end !***************************************************************************************** !> ! Compute the zeros of Legendre polynomial Pn(x) ! in the interval [-1,1], and the corresponding ! weighting coefficients for Gauss-Legendre ! integration subroutine legzo(n,x,w) ! Input : n --- Order of the Legendre polynomial ! Output: X(n) --- Zeros of the Legendre polynomial ! W(n) --- Corresponding weighting coefficients real(wp) f0 , f1 , fd , gd , p , pd , pf , q , w , wp_ , & & x , z , z0 integer i , j , k , n , n0 , nr dimension x(n) , w(n) n0 = (n+1)/2 pf = 0.0_wp pd = 0.0_wp do nr = 1 , n0 z = cos(3.1415926d0*(nr-0.25d0)/n) 50 z0 = z p = 1.0_wp do i = 1 , nr - 1 p = p*(z-x(i)) enddo f0 = 1.0_wp if ( nr==n0 .and. n/=2*int(n/2) ) z = 0.0_wp f1 = z do k = 2 , n pf = (2.0_wp-1.0_wp/k)*z*f1 - (1.0_wp-1.0_wp/k)*f0 pd = k*(f1-z*pf)/(1.0_wp-z*z) f0 = f1 f1 = pf enddo if ( z/=0.0 ) then fd = pf/p q = 0.0_wp do i = 1 , nr wp_ = 1.0_wp do j = 1 , nr if ( j/=i ) wp_ = wp_*(z-x(j)) enddo q = q + wp_ enddo gd = (pd-q*fd)/p z = z - fd/gd if ( abs(z-z0)>abs(z)*1.0d-15 ) goto 50 endif x(nr) = z x(n+1-nr) = -z w(nr) = 2.0_wp/((1.0_wp-z*z)*pd*pd) w(n+1-nr) = w(nr) enddo end !***************************************************************************************** !> ! Compute the prolate and oblate spheroidal angular ! functions of the first kind and their derivatives subroutine aswfa(m,n,c,x,Kd,Cv,S1f,S1d) ! Input : m --- Mode parameter, m = 0,1,2,... ! n --- Mode parameter, n = m,m+1,... ! c --- Spheroidal parameter ! x --- Argument of angular function, |x| < 1.0 ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! cv --- Characteristic value ! Output: S1F --- Angular function of the first kind ! S1D --- Derivative of the angular function of ! the first kind real(wp) a0 , c , ck , Cv , d0 , d1 , df , eps , r , S1d ,& & S1f , su1 , su2 , x , x0 , x1 integer ip , k , Kd , m , n , nm , nm2 dimension ck(200) , df(200) eps = 1.0d-14 x0 = x x = abs(x) ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 nm = 40 + int((n-m)/2+c) nm2 = nm/2 - 2 call sdmn(m,n,c,Cv,Kd,df) call sckb(m,n,c,df,ck) x1 = 1.0_wp - x*x if ( m==0 .and. x1==0.0_wp ) then a0 = 1.0_wp else a0 = x1**(0.5_wp*m) endif su1 = ck(1) do k = 1 , nm2 r = ck(k+1)*x1**k su1 = su1 + r if ( k>=10 .and. abs(r/su1)<eps ) exit enddo S1f = a0*x**ip*su1 if ( x==1.0_wp ) then if ( m==0 ) S1d = ip*ck(1) - 2.0_wp*ck(2) if ( m==1 ) S1d = -1.0d+100 if ( m==2 ) S1d = -2.0_wp*ck(1) if ( m>=3 ) S1d = 0.0_wp else d0 = ip - m/x1*x**(ip+1.0_wp) d1 = -2.0_wp*a0*x**(ip+1.0_wp) su2 = ck(2) do k = 2 , nm2 r = k*ck(k+1)*x1**(k-1.0_wp) su2 = su2 + r if ( k>=10 .and. abs(r/su2)<eps ) exit enddo S1d = d0*a0*su1 + d1*su2 endif if ( x0<0.0_wp .and. ip==0 ) S1d = -S1d if ( x0<0.0_wp .and. ip==1 ) S1f = -S1f x = x0 end !***************************************************************************************** !> ! Compute Bessel functions Jn(x) & Yn(x) and ! their derivatives subroutine jyna(n,x,Nm,Bj,Dj,By,Dy) ! Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) ! n --- Order of Jn(x) & Yn(x) ! Output: BJ(n) --- Jn(x) ! DJ(n) --- Jn'(x) ! BY(n) --- Yn(x) ! DY(n) --- Yn'(x) ! NM --- Highest order computed real(wp) Bj , bj0 , bj1 , bjk , By , by0 , by1 , cs , Dj ,& & dj0 , dj1 , Dy , dy0 , dy1 , f , f0 , f1 , f2 , x integer k , m , n , Nm dimension Bj(0:n) , By(0:n) , Dj(0:n) , Dy(0:n) Nm = n if ( x<1.0d-100 ) then do k = 0 , n Bj(k) = 0.0_wp Dj(k) = 0.0_wp By(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo Bj(0) = 1.0_wp Dj(1) = 0.5_wp return endif call jy01b(x,bj0,dj0,bj1,dj1,by0,dy0,by1,dy1) Bj(0) = bj0 Bj(1) = bj1 By(0) = by0 By(1) = by1 Dj(0) = dj0 Dj(1) = dj1 Dy(0) = dy0 Dy(1) = dy1 if ( n<=1 ) return if ( n<int(0.9*x) ) then do k = 2 , n bjk = 2.0_wp*(k-1.0_wp)/x*bj1 - bj0 Bj(k) = bjk bj0 = bj1 bj1 = bjk enddo else m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f2 = 0.0_wp f1 = 1.0d-100 f = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)/x*f1 - f2 if ( k<=Nm ) Bj(k) = f f2 = f1 f1 = f enddo if ( abs(bj0)>abs(bj1) ) then cs = bj0/f else cs = bj1/f2 endif do k = 0 , Nm Bj(k) = cs*Bj(k) enddo endif do k = 2 , Nm Dj(k) = Bj(k-1) - k/x*Bj(k) enddo f0 = By(0) f1 = By(1) do k = 2 , Nm f = 2.0_wp*(k-1.0_wp)/x*f1 - f0 By(k) = f f0 = f1 f1 = f enddo do k = 2 , Nm Dy(k) = By(k-1) - k*By(k)/x enddo end !***************************************************************************************** !> ! Compute parabolic cylinder functions Dv(x) ! and their derivatives subroutine pbdv(v,x,Dv,Dp,Pdf,Pdd) ! Input: x --- Argument of Dv(x) ! v --- Order of Dv(x) ! Output: DV(na) --- Dn+v0(x) ! DP(na) --- Dn+v0'(x) ! ( na = |n|, v0 = v-n, |v0| < 1, ! n = 0,±1,±2,… ) ! PDF --- Dv(x) ! PDD --- Dv'(x) real(wp) Dp , Dv , ep , f , f0 , f1 , pd , pd0 , pd1 , & & Pdd , Pdf , s0 , v , v0 , v1 , v2 , vh , x , xa integer ja , k , l , m , na , nk , nv dimension Dv(0:*) , Dp(0:*) xa = abs(x) vh = v v = v + sign(1.0_wp,v) nv = int(v) v0 = v - nv na = abs(nv) ep = exp(-0.25_wp*x*x) ja = 0 if ( na>=1 ) ja = 1 if ( v>=0.0 ) then if ( v0==0.0 ) then pd0 = ep pd1 = x*ep else do l = 0 , ja v1 = v0 + l if ( xa<=5.8 ) call dvsa(v1,x,pd1) if ( xa>5.8 ) call dvla(v1,x,pd1) if ( l==0 ) pd0 = pd1 enddo endif Dv(0) = pd0 Dv(1) = pd1 do k = 2 , na Pdf = x*pd1 - (k+v0-1.0_wp)*pd0 Dv(k) = Pdf pd0 = pd1 pd1 = Pdf enddo elseif ( x<=0.0 ) then if ( xa<=5.8d0 ) then call dvsa(v0,x,pd0) v1 = v0 - 1.0_wp call dvsa(v1,x,pd1) else call dvla(v0,x,pd0) v1 = v0 - 1.0_wp call dvla(v1,x,pd1) endif Dv(0) = pd0 Dv(1) = pd1 do k = 2 , na pd = (-x*pd1+pd0)/(k-1.0_wp-v0) Dv(k) = pd pd0 = pd1 pd1 = pd enddo elseif ( x<=2.0 ) then v2 = nv + v0 if ( nv==0 ) v2 = v2 - 1.0_wp nk = int(-v2) call dvsa(v2,x,f1) v1 = v2 + 1.0_wp call dvsa(v1,x,f0) Dv(nk) = f1 Dv(nk-1) = f0 do k = nk - 2 , 0 , -1 f = x*f0 + (k-v0+1.0_wp)*f1 Dv(k) = f f1 = f0 f0 = f enddo else if ( xa<=5.8 ) call dvsa(v0,x,pd0) if ( xa>5.8 ) call dvla(v0,x,pd0) Dv(0) = pd0 m = 100 + na f1 = 0.0_wp f0 = 1.0d-30 f = 0.0_wp do k = m , 0 , -1 f = x*f0 + (k-v0+1.0_wp)*f1 if ( k<=na ) Dv(k) = f f1 = f0 f0 = f enddo s0 = pd0/f do k = 0 , na Dv(k) = s0*Dv(k) enddo endif do k = 0 , na - 1 v1 = abs(v0) + k if ( v>=0.0_wp ) then Dp(k) = 0.5_wp*x*Dv(k) - Dv(k+1) else Dp(k) = -0.5_wp*x*Dv(k) - v1*Dv(k+1) endif enddo Pdf = Dv(na-1) Pdd = Dp(na-1) v = vh end !***************************************************************************************** !> ! Evaluate the integral of Struve function ! H0(t) with respect to t from 0 and x subroutine itsh0(x,Th0) ! Input : x --- Upper limit ( x ≥ 0 ) ! Output: TH0 --- Integration of H0(t) from 0 and x real(wp) a , a0 , a1 , af , bf , bg , el , r , rd , & & s , s0 , Th0 , ty , x , xp integer k dimension a(25) r = 1.0_wp if ( x<=30.0 ) then s = 0.5_wp do k = 1 , 100 rd = 1.0_wp if ( k==1 ) rd = 0.5_wp r = -r*rd*k/(k+1.0_wp)*(x/(2.0_wp*k+1.0_wp))**2 s = s + r if ( abs(r)<abs(s)*1.0d-12 ) exit enddo Th0 = 2.0_wp/pi*x*x*s else s = 1.0_wp do k = 1 , 12 r = -r*k/(k+1.0_wp)*((2.0_wp*k+1.0_wp)/x)**2 s = s + r if ( abs(r)<abs(s)*1.0d-12 ) exit enddo el = .57721566490153d0 s0 = s/(pi*x*x) + 2.0_wp/pi*(log(2.0_wp*x)+el) a0 = 1.0_wp a1 = 5.0_wp/8.0_wp a(1) = a1 do k = 1 , 20 af = ((1.5d0*(k+.5d0)*(k+5.0_wp/6.0_wp)*a1-0.5_wp*(k+.5d0) & & *(k+.5d0)*(k-0.5_wp)*a0))/(k+1.0_wp) a(k+1) = af a0 = a1 a1 = af enddo bf = 1.0_wp r = 1.0_wp do k = 1 , 10 r = -r/(x*x) bf = bf + a(2*k)*r enddo bg = a(1)/x r = 1.0_wp/x do k = 1 , 10 r = -r/(x*x) bg = bg + a(2*k+1)*r enddo xp = x + .25d0*pi ty = sqrt(2.0_wp/(pi*x))*(bg*cos(xp)-bf*sin(xp)) Th0 = ty + s0 endif end !***************************************************************************************** !> ! Evaluate the complex zeros of error function erf(z) ! using the modified Newton's iteration method subroutine cerzo(Nt,Zo) ! Input : NT --- Total number of zeros ! Output: ZO(L) --- L-th zero of erf(z), L=1,2,...,NT integer i , it , j , nr , Nt real(wp) pu , pv , px , py , w , w0 complex(wp) z , zd , zf , zfd , zgd , Zo , zp , zq , zw dimension Zo(Nt) w = 0.0_wp do nr = 1 , Nt pu = sqrt(pi*(4.0_wp*nr-0.5_wp)) pv = pi*sqrt(2.0_wp*nr-0.25d0) px = 0.5*pu - 0.5*log(pv)/pu py = 0.5*pu + 0.5*log(pv)/pu z = dcmplx(px,py) it = 0 50 it = it + 1 call cerf(z,zf,zd) zp = (1.0_wp,0.0_wp) do i = 1 , nr - 1 zp = zp*(z-Zo(i)) enddo zfd = zf/zp zq = (0.0_wp,0.0_wp) do i = 1 , nr - 1 zw = (1.0_wp,0.0_wp) do j = 1 , nr - 1 if ( j/=i ) zw = zw*(z-Zo(j)) enddo zq = zq + zw enddo zgd = (zd-zq*zfd)/zp z = z - zfd/zgd w0 = w w = abs(z) if ( it<=50 .and. abs((w-w0)/w)>1.0d-11 ) goto 50 Zo(nr) = z enddo end !***************************************************************************************** !> ! Compute gamma function Г(x) subroutine gamma2(x,Ga) ! Input : x --- Argument of Г(x) ! ( x is not equal to 0,-1,-2,…) ! Output: GA --- Г(x) real(wp) g , Ga , gr , r , x , z integer k , m , m1 dimension g(26) if ( x/=int(x) ) then r = 1.0_wp if ( abs(x)>1.0_wp ) then z = abs(x) m = int(z) do k = 1 , m r = r*(z-k) enddo z = z - m else z = x endif data g/1.0_wp , 0.5772156649015329d0 , -0.6558780715202538d0 , & & -0.420026350340952d-1 , 0.1665386113822915d0 , & & -.421977345555443d-1 , -.96219715278770d-2 , & & .72189432466630d-2 , -.11651675918591d-2 , & & -.2152416741149d-3 , .1280502823882d-3 , & & -.201348547807d-4 , -.12504934821d-5 , .11330272320d-5 , & & -.2056338417d-6 , .61160950d-8 , .50020075d-8 , & & -.11812746d-8 , .1043427d-9 , .77823d-11 , -.36968d-11 , & & .51d-12 , -.206d-13 , -.54d-14 , .14d-14 , .1d-15/ gr = g(26) do k = 25 , 1 , -1 gr = gr*z + g(k) enddo Ga = 1.0_wp/(gr*z) if ( abs(x)>1.0_wp ) then Ga = Ga*r if ( x<0.0_wp ) Ga = -pi/(x*Ga*sin(pi*x)) endif elseif ( x>0.0_wp ) then Ga = 1.0_wp m1 = x - 1 do k = 2 , m1 Ga = Ga*k enddo else Ga = 1.0e+300_wp endif end !***************************************************************************************** !> ! Compute the confluent hypergeometric function U(a,b,x) subroutine chgu(a,b,x,Hu,Md,Isfer) ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ( x > 0 ) ! Output: HU --- U(a,b,x) ! MD --- Method code ! ISFER --- Error flag real(wp) a , a00 , aa , b , b00 , Hu , hu1 , x integer id , id1 , Isfer , Md logical il1 , il2 , il3 , bl1 , bl2 , bl3 , bn aa = a - b + 1.0_wp Isfer = 0 il1 = a==int(a) .and. a<=0.0 il2 = aa==int(aa) .and. aa<=0.0 il3 = abs(a*(a-b+1.0))/x<=2.0 bl1 = x<=5.0 .or. (x<=10.0 .and. a<=2.0) bl2 = (x>5.0 .and. x<=12.5) .and. (a>=1.0 .and. b>=a+4.0) bl3 = x>12.5 .and. a>=5.0 .and. b>=a + 5.0 bn = b==int(b) .and. b/=0.0 id1 = -100 hu1 = 0.0_wp if ( b/=int(b) ) then call chgus(a,b,x,Hu,id1) Md = 1 if ( id1>=9 ) return hu1 = Hu endif if ( il1 .or. il2 .or. il3 ) then call chgul(a,b,x,Hu,id) Md = 2 if ( id>=9 ) return if ( id1>id ) then Md = 1 id = id1 Hu = hu1 endif endif if ( a>=1.0 ) then if ( bn .and. (bl1 .or. bl2 .or. bl3) ) then call chgubi(a,b,x,Hu,id) Md = 3 else call chguit(a,b,x,Hu,id) Md = 4 endif elseif ( b<=a ) then a00 = a b00 = b a = a - b + 1.0_wp b = 2.0_wp - b call chguit(a,b,x,Hu,id) Hu = x**(1.0_wp-b00)*Hu a = a00 b = b00 Md = 4 elseif ( bn .and. (.not.il1) ) then call chgubi(a,b,x,Hu,id) Md = 3 endif if ( id<6 ) Isfer = 6 end !***************************************************************************************** !> ! Compute lambda functions and their derivatives subroutine lamn(n,x,Nm,Bl,Dl) ! Input: x --- Argument of lambda function ! n --- Order of lambda function ! Output: BL(n) --- Lambda function of order n ! DL(n) --- Derivative of lambda function ! NM --- Highest order computed real(wp) bg , bk , Bl , bs , Dl , f , f0 , f1 , r , r0 , & & uk , x , x2 integer i , k , m , n , Nm dimension Bl(0:n) , Dl(0:n) Nm = n if ( abs(x)<1.0d-100 ) then do k = 0 , n Bl(k) = 0.0_wp Dl(k) = 0.0_wp enddo Bl(0) = 1.0_wp Dl(1) = 0.5_wp return endif if ( x<=12.0d0 ) then x2 = x*x do k = 0 , n bk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25d0*r*x2/(i*(i+k)) bk = bk + r if ( abs(r)<abs(bk)*1.0d-15 ) exit enddo Bl(k) = bk if ( k>=1 ) Dl(k-1) = -0.5_wp*x/k*bk enddo uk = 1.0_wp r = 1.0_wp do i = 1 , 50 r = -0.25d0*r*x2/(i*(i+n+1.0_wp)) uk = uk + r if ( abs(r)<abs(uk)*1.0d-15 ) exit enddo Dl(n) = -0.5_wp*x/(n+1.0_wp)*uk return endif if ( n==0 ) Nm = 1 m = msta1(x,200) if ( m<Nm ) then Nm = m else m = msta2(x,Nm,15) endif bs = 0.0_wp f = 0.0_wp f0 = 0.0_wp f1 = 1.0d-100 do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)*f1/x - f0 if ( k<=Nm ) Bl(k) = f if ( k==2*int(k/2) ) bs = bs + 2.0_wp*f f0 = f1 f1 = f enddo bg = bs - f do k = 0 , Nm Bl(k) = Bl(k)/bg enddo r0 = 1.0_wp do k = 1 , Nm r0 = 2.0_wp*r0*k/x Bl(k) = r0*Bl(k) enddo Dl(0) = -0.5_wp*x*Bl(1) do k = 1 , Nm Dl(k) = 2.0_wp*k/x*(Bl(k-1)-Bl(k)) enddo end !***************************************************************************************** !> ! Compute complete elliptic integrals K(k) and E(k) subroutine comelp(Hk,Ck,Ce) ! Input : K --- Modulus k ( 0 ≤ k ≤ 1 ) ! Output : CK --- K(k) ! CE --- E(k) real(wp) ae , ak , be , bk , Ce , Ck , Hk , pk pk = 1.0_wp - Hk*Hk if ( Hk==1.0 ) then Ck = 1.0e+300_wp Ce = 1.0_wp else ak = (((.01451196212d0*pk+.03742563713d0)*pk+.03590092383d0) & & *pk+.09666344259d0)*pk + 1.38629436112d0 bk = (((.00441787012d0*pk+.03328355346d0)*pk+.06880248576d0) & & *pk+.12498593597d0)*pk + .5d0 Ck = ak - bk*log(pk) ae = (((.01736506451d0*pk+.04757383546d0)*pk+.0626060122d0) & & *pk+.44325141463d0)*pk + 1.0_wp be = (((.00526449639d0*pk+.04069697526d0)*pk+.09200180037d0) & & *pk+.2499836831d0)*pk Ce = ae - be*log(pk) endif end !***************************************************************************************** !> ! Compute the incomplete beta function Ix(a,b) subroutine incob(a,b,x,Bix) ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ( 0 ≤ x ≤ 1 ) ! Output: BIX --- Ix(a,b) real(wp) a , b , Bix , bt , dk , fk , s0 , t1 , t2 , ta , & & tb , x integer k dimension dk(51) , fk(51) s0 = (a+1.0_wp)/(a+b+2.0_wp) call beta(a,b,bt) if ( x<=s0 ) then do k = 1 , 20 dk(2*k) = k*(b-k)*x/(a+2.0_wp*k-1.0_wp)/(a+2.0_wp*k) enddo do k = 0 , 20 dk(2*k+1) = -(a+k)*(a+b+k)*x/(a+2.d0*k)/(a+2.0*k+1.0) enddo t1 = 0.0_wp do k = 20 , 1 , -1 t1 = dk(k)/(1.0_wp+t1) enddo ta = 1.0_wp/(1.0_wp+t1) Bix = x**a*(1.0_wp-x)**b/(a*bt)*ta else do k = 1 , 20 fk(2*k) = k*(a-k)*(1.0_wp-x)/(b+2.*k-1.0)/(b+2.0*k) enddo do k = 0 , 20 fk(2*k+1) = -(b+k)*(a+b+k)*(1.d0-x)/(b+2.d0*k) & & /(b+2.d0*k+1.d0) enddo t2 = 0.0_wp do k = 20 , 1 , -1 t2 = fk(k)/(1.0_wp+t2) enddo tb = 1.0_wp/(1.0_wp+t2) Bix = 1.0_wp - x**a*(1.0_wp-x)**b/(b*bt)*tb endif end !***************************************************************************************** !> ! Compute the value of F for characteristic ! equation of Mathieu functions subroutine cvf(Kd,m,q,a,Mj,f) ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! A --- Characteristic value ! Output: F --- Value of F for characteristic equation real(wp) a , b , f , q , t0 , t1 , t2 integer ic , j , j0 , jf , Kd , l , l0 , m , Mj b = a ic = int(m/2) l = 0 l0 = 0 j0 = 2 jf = ic if ( Kd==1 ) l0 = 2 if ( Kd==1 ) j0 = 3 if ( Kd==2 .or. Kd==3 ) l = 1 if ( Kd==4 ) jf = ic - 1 t1 = 0.0_wp do j = Mj , ic + 1 , -1 t1 = -q*q/((2.0_wp*j+l)**2-b+t1) enddo if ( m<=2 ) then t2 = 0.0_wp if ( Kd==1 .and. m==0 ) t1 = t1 + t1 if ( Kd==1 .and. m==2 ) t1 = -2.0_wp*q*q/(4.0_wp-b+t1) - 4.0_wp if ( Kd==2 .and. m==1 ) t1 = t1 + q if ( Kd==3 .and. m==1 ) t1 = t1 - q else t0 = 0.0_wp if ( Kd==1 ) t0 = 4.0_wp - b + 2.0_wp*q*q/b if ( Kd==2 ) t0 = 1.0_wp - b + q if ( Kd==3 ) t0 = 1.0_wp - b - q if ( Kd==4 ) t0 = 4.0_wp - b t2 = -q*q/t0 do j = j0 , jf t2 = -q*q/((2.0_wp*j-l-l0)**2-b+t2) enddo endif f = (2.0_wp*ic+l)**2 + t1 + t2 - b end !***************************************************************************************** !> ! Compute Legendre polynomials Pn(z) and ! their derivatives Pn'(z) for a complex ! argument subroutine clpn(n,x,y,Cpn,Cpd) ! Input : x --- Real part of z ! y --- Imaginary part of z ! n --- Degree of Pn(z), n = 0,1,2,... ! Output: CPN(n) --- Pn(z) ! CPD(n) --- Pn'(z) complex(wp) cp0 , cp1 , Cpd , cpf , Cpn , z integer k , n real(wp) x , y dimension Cpn(0:n) , Cpd(0:n) z = dcmplx(x,y) Cpn(0) = (1.0_wp,0.0_wp) Cpn(1) = z Cpd(0) = (0.0_wp,0.0_wp) Cpd(1) = (1.0_wp,0.0_wp) cp0 = (1.0_wp,0.0_wp) cp1 = z do k = 2 , n cpf = (2.0_wp*k-1.0_wp)/k*z*cp1 - (k-1.0_wp)/k*cp0 Cpn(k) = cpf if ( abs(x)==1.0_wp .and. y==0.0_wp ) then Cpd(k) = 0.5_wp*x**(k+1)*k*(k+1.0_wp) else Cpd(k) = k*(cp1-z*cpf)/(1.0_wp-z*z) endif cp0 = cp1 cp1 = cpf enddo end !***************************************************************************************** !> ! Compute associated Legendre functions Qmn(x) ! and Qmn'(x) for a given order subroutine lqmns(m,n,x,Qm,Qd) ! Input : x --- Argument of Qmn(x) ! m --- Order of Qmn(x), m = 0,1,2,... ! n --- Degree of Qmn(x), n = 0,1,2,... ! Output: QM(n) --- Qmn(x) ! QD(n) --- Qmn'(x) integer k , km , l , ls , m , n real(wp) q0 , q00 , q01 , q0l , q10 , q11 , q1l , Qd , & & qf0 , qf1 , qf2 , qg0 , qg1 , qh0 , qh1 , qh2 , & & Qm , qm0 , qm1 , qmk real(wp) x , xq dimension Qm(0:n) , Qd(0:n) do k = 0 , n Qm(k) = 0.0_wp Qd(k) = 0.0_wp enddo if ( abs(x)==1.0_wp ) then do k = 0 , n Qm(k) = 1.0e+300_wp Qd(k) = 1.0e+300_wp enddo return endif ls = 1 if ( abs(x)>1.0_wp ) ls = -1 xq = sqrt(ls*(1.0_wp-x*x)) q0 = 0.5_wp*log(abs((x+1.0)/(x-1.0))) q00 = q0 q10 = -1.0_wp/xq q01 = x*q0 - 1.0_wp q11 = -ls*xq*(q0+x/(1.0_wp-x*x)) qf0 = q00 qf1 = q10 qm0 = 0.0_wp qm1 = 0.0_wp do k = 2 , m qm0 = -2.0_wp*(k-1.0)/xq*x*qf1 - ls*(k-1.0)*(2.0-k)*qf0 qf0 = qf1 qf1 = qm0 enddo if ( m==0 ) qm0 = q00 if ( m==1 ) qm0 = q10 Qm(0) = qm0 if ( abs(x)<1.0001_wp ) then if ( m==0 .and. n>0 ) then qf0 = q00 qf1 = q01 do k = 2 , n qf2 = ((2.0*k-1.0_wp)*x*qf1-(k-1.0)*qf0)/k Qm(k) = qf2 qf0 = qf1 qf1 = qf2 enddo endif qg0 = q01 qg1 = q11 do k = 2 , m qm1 = -2.0_wp*(k-1.0)/xq*x*qg1 - ls*k*(3.0-k)*qg0 qg0 = qg1 qg1 = qm1 enddo if ( m==0 ) qm1 = q01 if ( m==1 ) qm1 = q11 Qm(1) = qm1 if ( m==1 .and. n>1 ) then qh0 = q10 qh1 = q11 do k = 2 , n qh2 = ((2.0*k-1.0_wp)*x*qh1-k*qh0)/(k-1.0) Qm(k) = qh2 qh0 = qh1 qh1 = qh2 enddo elseif ( m>=2 ) then qg0 = q00 qg1 = q01 qh0 = q10 qh1 = q11 qmk = 0.0_wp do l = 2 , n q0l = ((2.0_wp*l-1.0_wp)*x*qg1-(l-1.0_wp)*qg0)/l q1l = ((2.0*l-1.0_wp)*x*qh1-l*qh0)/(l-1.0_wp) qf0 = q0l qf1 = q1l do k = 2 , m qmk = -2.0_wp*(k-1.0)/xq*x*qf1 - ls*(k+l-1.0)*(l+2.0-k)& & *qf0 qf0 = qf1 qf1 = qmk enddo Qm(l) = qmk qg0 = qg1 qg1 = q0l qh0 = qh1 qh1 = q1l enddo endif else if ( abs(x)>1.1 ) then km = 40 + m + n else km = (40+m+n)*int(-1.0-1.8*log(x-1.0)) endif qf2 = 0.0_wp qf1 = 1.0_wp do k = km , 0 , -1 qf0 = ((2.0*k+3.0_wp)*x*qf1-(k+2.0-m)*qf2)/(k+m+1.0) if ( k<=n ) Qm(k) = qf0 qf2 = qf1 qf1 = qf0 enddo do k = 0 , n Qm(k) = Qm(k)*qm0/qf0 enddo endif if ( abs(x)<1.0_wp ) then do k = 0 , n Qm(k) = (-1)**m*Qm(k) enddo endif Qd(0) = ((1.0_wp-m)*Qm(1)-x*Qm(0))/(x*x-1.0) do k = 1 , n Qd(k) = (k*x*Qm(k)-(k+m)*Qm(k-1))/(x*x-1.0) enddo end !***************************************************************************************** !> ! Compute modified Bessel functions Iv(z) and ! Kv(z) and their derivatives with a complex ! argument and a large order subroutine ciklv(v,z,Cbiv,Cdiv,Cbkv,Cdkv) ! Input: v --- Order of Iv(z) and Kv(z) ! z --- Complex argument ! Output: CBIV --- Iv(z) ! CDIV --- Iv'(z) ! CBKV --- Kv(z) ! CDKV --- Kv'(z) real(wp) a , v , v0 , vr complex(wp) Cbiv , Cbkv , Cdiv , Cdkv , ceta , cf , cfi , cfk , & & csi , csk , ct , ct2 , cws , z integer i , k , km , l , l0 , lf dimension cf(12) , a(91) km = 12 call cjk(km,a) do l = 1 , 0 , -1 v0 = v - l cws = sqrt(1.0_wp+(z/v0)*(z/v0)) ceta = cws + log(z/v0/(1.0_wp+cws)) ct = 1.0_wp/cws ct2 = ct*ct do k = 1 , km l0 = k*(k+1)/2 + 1 lf = l0 + k cf(k) = a(lf) do i = lf - 1 , l0 , -1 cf(k) = cf(k)*ct2 + a(i) enddo cf(k) = cf(k)*ct**k enddo vr = 1.0_wp/v0 csi = (1.0_wp,0.0_wp) do k = 1 , km csi = csi + cf(k)*vr**k enddo Cbiv = sqrt(ct/(2.0_wp*pi*v0))*exp(v0*ceta)*csi if ( l==1 ) cfi = Cbiv csk = (1.0_wp,0.0_wp) do k = 1 , km csk = csk + (-1)**k*cf(k)*vr**k enddo Cbkv = sqrt(pi*ct/(2.0_wp*v0))*exp(-v0*ceta)*csk if ( l==1 ) cfk = Cbkv enddo Cdiv = cfi - v/z*Cbiv Cdkv = -cfk - v/z*Cbkv end !***************************************************************************************** !> ! Compute complete and incomplete elliptic ! integrals F(k,phi) and E(k,phi) subroutine elit(Hk,Phi,Fe,Ee) ! Input : HK --- Modulus k ( 0 ≤ k ≤ 1 ) ! Phi --- Argument ( in degrees ) ! Output : FE --- F(k,phi) ! EE --- E(k,phi) real(wp) a , a0 , b , b0 , c , ce , ck , d , d0 , Ee , & & fac , Fe , g , Hk , Phi , r integer n g = 0.0_wp a0 = 1.0_wp b0 = sqrt(1.0_wp-Hk*Hk) d0 = (pi/180.0d0)*Phi r = Hk*Hk if ( Hk==1.0_wp .and. Phi==90.0d0 ) then Fe = 1.0e+300_wp Ee = 1.0_wp elseif ( Hk==1.0_wp ) then Fe = log((1.0_wp+sin(d0))/cos(d0)) Ee = sin(d0) else fac = 1.0_wp d = 0.0_wp do n = 1 , 40 a = (a0+b0)/2.0_wp b = sqrt(a0*b0) c = (a0-b0)/2.0_wp fac = 2.0_wp*fac r = r + fac*c*c if ( Phi/=90.0d0 ) then d = d0 + atan((b0/a0)*tan(d0)) g = g + c*sin(d) d0 = d + pi*int(d/pi+.5d0) endif a0 = a b0 = b if ( c<1.0d-7 ) exit enddo ck = pi/(2.0_wp*a) ce = pi*(2.0_wp-r)/(4.0_wp*a) if ( Phi==90.0d0 ) then Fe = ck Ee = ce else Fe = d/(fac*a) Ee = Fe*ce/ck + g endif endif end !***************************************************************************************** !> ! Compute the elliptic integral of the third kind ! using Gauss-Legendre quadrature subroutine elit3(Phi,Hk,c,El3) ! Input : Phi --- Argument ( in degrees ) ! k --- Modulus ( 0 ≤ k ≤ 1.0 ) ! c --- Parameter ( 0 ≤ c ≤ 1.0 ) ! Output: EL3 --- Value of the elliptic integral of the ! third kind real(wp) c , c0 , c1 , c2 , El3 , f1 , f2 , Hk , Phi , t ,& & t1 , t2 , w integer i dimension t(10) , w(10) logical lb1 , lb2 data t/.9931285991850949d0 , .9639719272779138d0 , & & .9122344282513259d0 , .8391169718222188d0 , & & .7463319064601508d0 , .6360536807265150d0 , & & .5108670019508271d0 , .3737060887154195d0 , & & .2277858511416451d0 , .7652652113349734d-1/ data w/.1761400713915212d-1 , .4060142980038694d-1 , & & .6267204833410907d-1 , .8327674157670475d-1 , & & .1019301198172404d0 , .1181945319615184d0 , & & .1316886384491766d0 , .1420961093183820d0 , & & .1491729864726037d0 , .1527533871307258d0/ lb1 = Hk==1.0_wp .and. abs(Phi-90.0)<=1.0d-8 lb2 = c==1.0_wp .and. abs(Phi-90.0)<=1.0d-8 if ( lb1 .or. lb2 ) then El3 = 1.0e+300_wp return endif c1 = 0.87266462599716d-2*Phi c2 = c1 El3 = 0.0_wp do i = 1 , 10 c0 = c2*t(i) t1 = c1 + c0 t2 = c1 - c0 f1 = 1.0_wp/((1.0_wp-c*sin(t1)*sin(t1)) & & *sqrt(1.0_wp-Hk*Hk*sin(t1)*sin(t1))) f2 = 1.0_wp/((1.0_wp-c*sin(t2)*sin(t2)) & & *sqrt(1.0_wp-Hk*Hk*sin(t2)*sin(t2))) El3 = El3 + w(i)*(f1+f2) enddo El3 = c1*El3 end !***************************************************************************************** !> ! Compute exponential integral Ei(x) subroutine eix(x,Ei) ! Input : x --- Argument of Ei(x) ! Output: EI --- Ei(x) real(wp) Ei , ga , r , x integer k if ( x==0.0 ) then Ei = -1.0e+300_wp elseif ( x<0 ) then call e1xb(-x,Ei) Ei = -Ei elseif ( abs(x)<=40.0 ) then ! Power series around x=0 Ei = 1.0_wp r = 1.0_wp do k = 1 , 100 r = r*k*x/(k+1.0_wp)**2 Ei = Ei + r if ( abs(r/Ei)<=1.0d-15 ) exit enddo ga = 0.5772156649015328d0 Ei = ga + log(x) + x*Ei else ! Asymptotic expansion (the series is not convergent) Ei = 1.0_wp r = 1.0_wp do k = 1 , 20 r = r*k/x Ei = Ei + r enddo Ei = exp(x)/x*Ei endif end subroutine eixz(z,Cei) ! ! ============================================ ! Purpose: Compute exponential integral Ei(x) ! Input : x --- Complex argument of Ei(x) ! Output: EI --- Ei(x) ! ============================================ ! implicit none complex(wp) z , Cei call e1z(-z,Cei) Cei = -Cei if ( aimag(z)>0 ) then Cei = Cei + (0d0,1d0)*pi elseif ( aimag(z)<0 ) then Cei = Cei - (0d0,1d0)*pi elseif ( aimag(z)==0 ) then if ( real(z,wp)>0 ) Cei = Cei + (0d0,1d0)*sign(pi,aimag(z)) endif end subroutine e1xb(x,e1) ! ! ============================================ ! Purpose: Compute exponential integral E1(x) ! Input : x --- Argument of E1(x) ! Output: E1 --- E1(x) ( x > 0 ) ! ============================================ ! implicit none real(wp) e1 , ga , r , t , t0 , x integer k , m if ( x==0.0 ) then e1 = 1.0e+300_wp elseif ( x<=1.0 ) then e1 = 1.0_wp r = 1.0_wp do k = 1 , 25 r = -r*k*x/(k+1.0_wp)**2 e1 = e1 + r if ( abs(r)<=abs(e1)*1.0d-15 ) exit enddo ga = 0.5772156649015328d0 e1 = -ga - log(x) + x*e1 else m = 20 + int(80.0/x) t0 = 0.0_wp do k = m , 1 , -1 t0 = k/(1.0_wp+k/(x+t0)) enddo t = 1.0_wp/(x+t0) e1 = exp(-x)*t endif end subroutine chgm(a,b,x,Hg) ! ! =================================================== ! Purpose: Compute confluent hypergeometric function ! M(a,b,x) ! Input : a --- Parameter ! b --- Parameter ( b <> 0,-1,-2,... ) ! x --- Argument ! Output: HG --- M(a,b,x) ! Routine called: CGAMA for computing complex ln[Г(x)] ! =================================================== ! implicit none real(wp) a , a0 , a1 , b , Hg , hg1 , hg2 , r1 , r2 ,& & rg , sum1 , sum2 , tai , tar , tbai , tbar , & & tbi , tbr , x real(wp) x0 , xg , y , y0 , y1 complex(wp) cta , ctb , ctba integer i , j , la , n , nl a0 = a a1 = a x0 = x Hg = 0.0_wp ! DLMF 13.2.39 if ( x<0.0_wp ) then a = b - a a0 = a x = abs(x) endif nl = 0 la = 0 if ( a>=2.0_wp ) then ! preparing terms for DLMF 13.3.1 nl = 1 la = int(a) a = a - la - 1.0_wp endif y0 = 0.0_wp y1 = 0.0_wp do n = 0 , nl if ( a0>=2.0_wp ) a = a + 1.0_wp if ( x<=30.0d0+abs(b) .or. a<0.0_wp ) then Hg = 1.0_wp rg = 1.0_wp do j = 1 , 500 rg = rg*(a+j-1.0_wp)/(j*(b+j-1.0_wp))*x Hg = Hg + rg if ( Hg/=0d0 .and. abs(rg/Hg)<1.0d-15 ) then ! DLMF 13.2.39 (cf. above) if ( x0<0.0_wp ) Hg = Hg*exp(x0) goto 50 endif enddo else ! DLMF 13.7.2 & 13.2.4, SUM2 corresponds to first sum y = 0.0_wp call cgama(a,y,0,tar,tai) cta = dcmplx(tar,tai) y = 0.0_wp call cgama(b,y,0,tbr,tbi) ctb = dcmplx(tbr,tbi) xg = b - a y = 0.0_wp call cgama(xg,y,0,tbar,tbai) ctba = dcmplx(tbar,tbai) sum1 = 1.0_wp sum2 = 1.0_wp r1 = 1.0_wp r2 = 1.0_wp do i = 1 , 8 r1 = -r1*(a+i-1.0_wp)*(a-b+i)/(x*i) r2 = -r2*(b-a+i-1.0_wp)*(a-i)/(x*i) sum1 = sum1 + r1 sum2 = sum2 + r2 enddo if ( x0>=0.0_wp ) then hg1 = dble(exp(ctb-ctba))*x**(-a)*cos(pi*a)*sum1 hg2 = dble(exp(ctb-cta+x))*x**(a-b)*sum2 else ! DLMF 13.2.39 (cf. above) hg1 = dble(exp(ctb-ctba+x0))*x**(-a)*cos(pi*a)*sum1 hg2 = dble(exp(ctb-cta))*x**(a-b)*sum2 endif Hg = hg1 + hg2 endif 50 if ( n==0 ) y0 = Hg if ( n==1 ) y1 = Hg enddo if ( a0>=2.0_wp ) then ! DLMF 13.3.1 do i = 1 , la - 1 Hg = ((2.0_wp*a-b+x)*y1+(b-a)*y0)/a y0 = y1 y1 = Hg a = a + 1.0_wp enddo endif a = a1 x = x0 end subroutine hygfx(a,b,c,x,Hf,Isfer) ! ! ==================================================== ! Purpose: Compute hypergeometric function F(a,b,c,x) ! Input : a --- Parameter ! b --- Parameter ! c --- Parameter, c <> 0,-1,-2,... ! x --- Argument ( x < 1 ) ! Output: HF --- F(a,b,c,x) ! ISFER --- Error flag ! Routines called: ! (1) GAMMA2 for computing gamma function ! (2) PSI_SPEC for computing psi function ! ==================================================== ! implicit none real(wp) a , a0 , aa , b , bb , c , c0 , c1 , el , eps , & & f0 , f1 , g0 , g1 , g2 , g3 , ga , gabc , gam , & & gb real(wp) gbm , gc , gca , gcab , gcb , gm , Hf , hw , pa ,& & pb , r , r0 , r1 , rm , rp , sm , sp , sp0 ,& & x real(wp) x1 integer Isfer , j , k , m , nm logical l0 , l1 , l2 , l3 , l4 , l5 el = .5772156649015329d0 Isfer = 0 l0 = c==int(c) .and. c<0.0 l1 = 1.0_wp - x<1.0d-15 .and. c - a - b<=0.0 l2 = a==int(a) .and. a<0.0 l3 = b==int(b) .and. b<0.0 l4 = c - a==int(c-a) .and. c - a<=0.0 l5 = c - b==int(c-b) .and. c - b<=0.0 if ( l0 .or. l1 ) then Isfer = 3 return endif eps = 1.0d-15 if ( x>0.95 ) eps = 1.0d-8 if ( x==0.0 .or. a==0.0 .or. b==0.0 ) then Hf = 1.0_wp return elseif ( 1.0_wp-x==eps .and. c-a-b>0.0 ) then call gamma2(c,gc) call gamma2(c-a-b,gcab) call gamma2(c-a,gca) call gamma2(c-b,gcb) Hf = gc*gcab/(gca*gcb) return elseif ( 1.0_wp+x<=eps .and. abs(c-a+b-1.0)<=eps ) then g0 = sqrtpi*2.0_wp**(-a) call gamma2(c,g1) call gamma2(1.0_wp+a/2.0-b,g2) call gamma2(0.5_wp+0.5*a,g3) Hf = g0*g1/(g2*g3) return elseif ( l2 .or. l3 ) then if ( l2 ) nm = int(abs(a)) if ( l3 ) nm = int(abs(b)) Hf = 1.0_wp r = 1.0_wp do k = 1 , nm r = r*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*x Hf = Hf + r enddo return elseif ( l4 .or. l5 ) then if ( l4 ) nm = int(abs(c-a)) if ( l5 ) nm = int(abs(c-b)) Hf = 1.0_wp r = 1.0_wp do k = 1 , nm r = r*(c-a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c+k-1.0_wp))*x Hf = Hf + r enddo Hf = (1.0_wp-x)**(c-a-b)*Hf return endif aa = a bb = b x1 = x if ( x<0.0_wp ) then x = x/(x-1.0_wp) if ( c>a .and. b<a .and. b>0.0 ) then a = bb b = aa endif b = c - b endif hw = 0.0_wp if ( x>=0.75d0 ) then gm = 0.0_wp if ( abs(c-a-b-int(c-a-b))<1.0d-15 ) then m = int(c-a-b) call gamma2(a,ga) call gamma2(b,gb) call gamma2(c,gc) call gamma2(a+m,gam) call gamma2(b+m,gbm) call psi_spec(a,pa) call psi_spec(b,pb) if ( m/=0 ) gm = 1.0_wp do j = 1 , abs(m) - 1 gm = gm*j enddo rm = 1.0_wp do j = 1 , abs(m) rm = rm*j enddo f0 = 1.0_wp r0 = 1.0_wp r1 = 1.0_wp sp0 = 0.d0 sp = 0.0_wp if ( m>=0 ) then c0 = gm*gc/(gam*gbm) c1 = -gc*(x-1.0_wp)**m/(ga*gb*rm) do k = 1 , m - 1 r0 = r0*(a+k-1.0_wp)*(b+k-1.0)/(k*(k-m))*(1.0-x) f0 = f0 + r0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/(a+k-1.0) + 1.0/(b+k-1.0) - 1.0/k enddo f1 = pa + pb + sp0 + 2.0_wp*el + log(1.0_wp-x) do k = 1 , 250 sp = sp + (1.0_wp-a)/(k*(a+k-1.0)) + (1.0-b) & & /(k*(b+k-1.0)) sm = 0.0_wp do j = 1 , m sm = sm + (1.0_wp-a)/((j+k)*(a+j+k-1.0)) & & + 1.0/(b+j+k-1.0) enddo rp = pa + pb + 2.0_wp*el + sp + sm + log(1.0_wp-x) r1 = r1*(a+m+k-1.0_wp)*(b+m+k-1.0)/(k*(m+k))*(1.0-x) f1 = f1 + r1*rp if ( abs(f1-hw)<abs(f1)*eps ) exit hw = f1 enddo Hf = f0*c0 + f1*c1 elseif ( m<0 ) then m = -m c0 = gm*gc/(ga*gb*(1.0_wp-x)**m) c1 = -(-1)**m*gc/(gam*gbm*rm) do k = 1 , m - 1 r0 = r0*(a-m+k-1.0_wp)*(b-m+k-1.0)/(k*(k-m))*(1.0-x) f0 = f0 + r0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/k enddo f1 = pa + pb - sp0 + 2.0_wp*el + log(1.0_wp-x) do k = 1 , 250 sp = sp + (1.0_wp-a)/(k*(a+k-1.0)) + (1.0-b) & & /(k*(b+k-1.0)) sm = 0.0_wp do j = 1 , m sm = sm + 1.0_wp/(j+k) enddo rp = pa + pb + 2.0_wp*el + sp - sm + log(1.0_wp-x) r1 = r1*(a+k-1.0_wp)*(b+k-1.0)/(k*(m+k))*(1.0-x) f1 = f1 + r1*rp if ( abs(f1-hw)<abs(f1)*eps ) exit hw = f1 enddo Hf = f0*c0 + f1*c1 endif else call gamma2(a,ga) call gamma2(b,gb) call gamma2(c,gc) call gamma2(c-a,gca) call gamma2(c-b,gcb) call gamma2(c-a-b,gcab) call gamma2(a+b-c,gabc) c0 = gc*gcab/(gca*gcb) c1 = gc*gabc/(ga*gb)*(1.0_wp-x)**(c-a-b) Hf = 0.0_wp r0 = c0 r1 = c1 do k = 1 , 250 r0 = r0*(a+k-1.0_wp)*(b+k-1.0)/(k*(a+b-c+k))*(1.0-x) r1 = r1*(c-a+k-1.0_wp)*(c-b+k-1.0)/(k*(c-a-b+k))*(1.0-x) Hf = Hf + r0 + r1 if ( abs(Hf-hw)<abs(Hf)*eps ) exit hw = Hf enddo Hf = Hf + c0 + c1 endif else a0 = 1.0_wp if ( c>a .and. c<2.0_wp*a .and. c>b .and. c<2.0_wp*b ) then a0 = (1.0_wp-x)**(c-a-b) a = c - a b = c - b endif Hf = 1.0_wp r = 1.0_wp do k = 1 , 250 r = r*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*x Hf = Hf + r if ( abs(Hf-hw)<=abs(Hf)*eps ) exit hw = Hf enddo Hf = a0*Hf endif if ( x1<0.0_wp ) then x = x1 c0 = 1.0_wp/(1.0_wp-x)**aa Hf = c0*Hf endif a = aa b = bb if ( k>120 ) Isfer = 5 end subroutine cchg(a,b,z,Chg) ! ! =================================================== ! Purpose: Compute confluent hypergeometric function ! M(a,b,z) with real parameters a, b and a ! complex argument z ! Input : a --- Parameter ! b --- Parameter ! z --- Complex argument ! Output: CHG --- M(a,b,z) ! Routine called: CGAMA for computing complex ln[Г(x)] ! =================================================== ! implicit none real(wp) a , a0 , a1 , b , ba , g1i , g1r , g2i , g2r , & & g3i , g3r , phi , x , x0 , y complex(wp) cfac , cg1 , cg2 , cg3 , Chg , chg1 , chg2 , chw , ci ,& & cr , cr1 , cr2 , crg , cs1 , cs2 , cy0 , cy1 , z , z0 integer i , j , k , la , m , n , nl , ns ci = (0.0_wp,1.0_wp) a0 = a a1 = a z0 = z if ( b==0.0 .or. b==-int(abs(b)) ) then Chg = (1.0e+300_wp,0.0_wp) elseif ( a==0.0_wp .or. z==0.0_wp ) then Chg = (1.0_wp,0.0_wp) elseif ( a==-1.0_wp ) then Chg = 1.0_wp - z/b elseif ( a==b ) then Chg = exp(z) elseif ( a-b==1.0_wp ) then Chg = (1.0_wp+z/b)*exp(z) elseif ( a==1.0_wp .and. b==2.0_wp ) then Chg = (exp(z)-1.0_wp)/z elseif ( a==int(a) .and. a<0.0_wp ) then m = int(-a) cr = (1.0_wp,0.0_wp) Chg = (1.0_wp,0.0_wp) do k = 1 , m cr = cr*(a+k-1.0_wp)/k/(b+k-1.0_wp)*z Chg = Chg + cr enddo else x0 = real(z,wp) if ( x0<0.0_wp ) then a = b - a a0 = a z = -z endif nl = 0 la = 0 if ( a>=2.0_wp ) then nl = 1 la = int(a) a = a - la - 1.0_wp endif ns = 0 do n = 0 , nl if ( a0>=2.0_wp ) a = a + 1.0_wp if ( abs(z)<20.0d0+abs(b) .or. a<0.0_wp ) then Chg = (1.0_wp,0.0_wp) crg = (1.0_wp,0.0_wp) do j = 1 , 500 crg = crg*(a+j-1.0_wp)/(j*(b+j-1.0_wp))*z Chg = Chg + crg if ( abs((Chg-chw)/Chg)<1.d-15 ) goto 20 chw = Chg enddo else y = 0.0_wp call cgama(a,y,0,g1r,g1i) cg1 = dcmplx(g1r,g1i) y = 0.0_wp call cgama(b,y,0,g2r,g2i) cg2 = dcmplx(g2r,g2i) ba = b - a y = 0.0_wp call cgama(ba,y,0,g3r,g3i) cg3 = dcmplx(g3r,g3i) cs1 = (1.0_wp,0.0_wp) cs2 = (1.0_wp,0.0_wp) cr1 = (1.0_wp,0.0_wp) cr2 = (1.0_wp,0.0_wp) do i = 1 , 8 cr1 = -cr1*(a+i-1.0_wp)*(a-b+i)/(z*i) cr2 = cr2*(b-a+i-1.0_wp)*(i-a)/(z*i) cs1 = cs1 + cr1 cs2 = cs2 + cr2 enddo x = real(z,wp) y = aimag(z) if ( x==0.0 .and. y>=0.0 ) then phi = halfpi elseif ( x==0.0 .and. y<=0.0 ) then phi = -halfpi else phi = atan(y/x) endif if ( phi>-halfpi .and. phi<1.5*pi ) ns = 1 if ( phi>-1.5*pi .and. phi<=-halfpi ) ns = -1 cfac = exp(ns*ci*pi*a) if ( y==0.0_wp ) cfac = cos(pi*a) chg1 = exp(cg2-cg3)*z**(-a)*cfac*cs1 chg2 = exp(cg2-cg1+z)*z**(a-b)*cs2 Chg = chg1 + chg2 endif 20 if ( n==0 ) cy0 = Chg if ( n==1 ) cy1 = Chg enddo if ( a0>=2.0_wp ) then do i = 1 , la - 1 Chg = ((2.0_wp*a-b+z)*cy1+(b-a)*cy0)/a cy0 = cy1 cy1 = Chg a = a + 1.0_wp enddo endif if ( x0<0.0_wp ) Chg = Chg*exp(-z) endif a = a1 z = z0 end subroutine hygfz(a,b,c,z,Zhf,Isfer) ! ! ====================================================== ! Purpose: Compute the hypergeometric function for a ! complex argument, F(a,b,c,z) ! Input : a --- Parameter ! b --- Parameter ! c --- Parameter, c <> 0,-1,-2,... ! z --- Complex argument ! Output: ZHF --- F(a,b,c,z) ! ISFER --- Error flag ! Routines called: ! (1) GAMMA2 for computing gamma function ! (2) PSI_SPEC for computing psi function ! ====================================================== ! implicit none real(wp) a , a0 , aa , b , bb , c , ca , cb , el , eps , & & g0 , g1 , g2 , g3 , ga , gab , gabc , gam , gb , & & gba real(wp) gbm , gc , gca , gcab , gcb , gcbk , gm , pa , & & pac , pb , pca , rk1 , rk2 , rm , sj1 , & & sj2 , sm , sp , sp0 real(wp) sq , t0 , w0 , ws , x , y integer Isfer , j , k , m , mab , mcab , nca , ncb , nm complex(wp) z , z00 , z1 , zc0 , zc1 , zf0 , zf1 , Zhf , zp , zp0 ,& & zr , zr0 , zr1 , zw logical l0 , l1 , l2 , l3 , l4 , l5 , l6 x = real(z,wp) y = aimag(z) eps = 1.0d-15 Isfer = 0 l0 = c==int(c) .and. c<0.0_wp l1 = abs(1.0_wp-x)<eps .and. y==0.0_wp .and. c - a - b<=0.0_wp l2 = abs(z+1.0_wp)<eps .and. abs(c-a+b-1.0_wp)<eps l3 = a==int(a) .and. a<0.0_wp l4 = b==int(b) .and. b<0.0_wp l5 = c - a==int(c-a) .and. c - a<=0.0_wp l6 = c - b==int(c-b) .and. c - b<=0.0_wp aa = a bb = b a0 = abs(z) if ( a0>0.95d0 ) eps = 1.0d-8 el = .5772156649015329d0 if ( l0 .or. l1 ) then Isfer = 3 return endif nm = 0 if ( a0==0.0_wp .or. a==0.0_wp .or. b==0.0_wp ) then Zhf = (1.0_wp,0.0_wp) elseif ( z==1.0_wp .and. c-a-b>0.0_wp ) then call gamma2(c,gc) call gamma2(c-a-b,gcab) call gamma2(c-a,gca) call gamma2(c-b,gcb) Zhf = gc*gcab/(gca*gcb) elseif ( l2 ) then g0 = sqrtpi*2.0_wp**(-a) call gamma2(c,g1) call gamma2(1.0_wp+a/2.0_wp-b,g2) call gamma2(0.5_wp+0.5_wp*a,g3) Zhf = g0*g1/(g2*g3) elseif ( l3 .or. l4 ) then if ( l3 ) nm = int(abs(a)) if ( l4 ) nm = int(abs(b)) Zhf = (1.0_wp,0.0_wp) zr = (1.0_wp,0.0_wp) do k = 1 , nm zr = zr*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*z Zhf = Zhf + zr enddo elseif ( l5 .or. l6 ) then if ( l5 ) nm = int(abs(c-a)) if ( l6 ) nm = int(abs(c-b)) Zhf = (1.0_wp,0.0_wp) zr = (1.0_wp,0.0_wp) do k = 1 , nm zr = zr*(c-a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c+k-1.0_wp))*z Zhf = Zhf + zr enddo Zhf = (1.0_wp-z)**(c-a-b)*Zhf elseif ( a0<=1.0_wp ) then if ( x<0.0_wp ) then z1 = z/(z-1.0_wp) if ( c>a .and. b<a .and. b>0.0 ) then a = bb b = aa endif zc0 = 1.0_wp/((1.0_wp-z)**a) Zhf = (1.0_wp,0.0_wp) zr0 = (1.0_wp,0.0_wp) do k = 1 , 500 zr0 = zr0*(a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c+k-1.0_wp))*z1 Zhf = Zhf + zr0 if ( abs(Zhf-zw)<abs(Zhf)*eps ) exit zw = Zhf enddo Zhf = zc0*Zhf elseif ( a0>=0.90d0 ) then gm = 0.0_wp mcab = int(c-a-b+eps*sign(1.0_wp,c-a-b)) if ( abs(c-a-b-mcab)<eps ) then m = int(c-a-b) call gamma2(a,ga) call gamma2(b,gb) call gamma2(c,gc) call gamma2(a+m,gam) call gamma2(b+m,gbm) call psi_spec(a,pa) call psi_spec(b,pb) if ( m/=0 ) gm = 1.0_wp do j = 1 , abs(m) - 1 gm = gm*j enddo rm = 1.0_wp do j = 1 , abs(m) rm = rm*j enddo zf0 = (1.0_wp,0.0_wp) zr0 = (1.0_wp,0.0_wp) zr1 = (1.0_wp,0.0_wp) sp0 = 0.d0 sp = 0.0_wp if ( m>=0 ) then zc0 = gm*gc/(gam*gbm) zc1 = -gc*(z-1.0_wp)**m/(ga*gb*rm) do k = 1 , m - 1 zr0 = zr0*(a+k-1.d0)*(b+k-1.d0)/(k*(k-m))*(1.d0-z) zf0 = zf0 + zr0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/(a+k-1.0_wp) + 1.0/(b+k-1.0_wp) & & - 1.d0/k enddo zf1 = pa + pb + sp0 + 2.0_wp*el + log(1.0_wp-z) do k = 1 , 500 sp = sp + (1.0_wp-a)/(k*(a+k-1.0_wp)) + (1.0_wp-b) & & /(k*(b+k-1.0_wp)) sm = 0.0_wp do j = 1 , m sm = sm + (1.0_wp-a)/((j+k)*(a+j+k-1.0_wp)) & & + 1.0_wp/(b+j+k-1.0_wp) enddo zp = pa + pb + 2.0_wp*el + sp + sm + log(1.0_wp-z) zr1 = zr1*(a+m+k-1.0_wp)*(b+m+k-1.0_wp)/(k*(m+k)) & & *(1.0_wp-z) zf1 = zf1 + zr1*zp if ( abs(zf1-zw)<abs(zf1)*eps ) exit zw = zf1 enddo Zhf = zf0*zc0 + zf1*zc1 elseif ( m<0 ) then m = -m zc0 = gm*gc/(ga*gb*(1.0_wp-z)**m) zc1 = -(-1)**m*gc/(gam*gbm*rm) do k = 1 , m - 1 zr0 = zr0*(a-m+k-1.0_wp)*(b-m+k-1.0_wp)/(k*(k-m)) & & *(1.0_wp-z) zf0 = zf0 + zr0 enddo do k = 1 , m sp0 = sp0 + 1.0_wp/k enddo zf1 = pa + pb - sp0 + 2.0_wp*el + log(1.0_wp-z) do k = 1 , 500 sp = sp + (1.0_wp-a)/(k*(a+k-1.0_wp)) + (1.0_wp-b) & & /(k*(b+k-1.0_wp)) sm = 0.0_wp do j = 1 , m sm = sm + 1.0_wp/(j+k) enddo zp = pa + pb + 2.0_wp*el + sp - sm + log(1.0_wp-z) zr1 = zr1*(a+k-1.d0)*(b+k-1.d0)/(k*(m+k))*(1.d0-z) zf1 = zf1 + zr1*zp if ( abs(zf1-zw)<abs(zf1)*eps ) exit zw = zf1 enddo Zhf = zf0*zc0 + zf1*zc1 endif else call gamma2(a,ga) call gamma2(b,gb) call gamma2(c,gc) call gamma2(c-a,gca) call gamma2(c-b,gcb) call gamma2(c-a-b,gcab) call gamma2(a+b-c,gabc) zc0 = gc*gcab/(gca*gcb) zc1 = gc*gabc/(ga*gb)*(1.0_wp-z)**(c-a-b) Zhf = (0.0_wp,0.0_wp) zr0 = zc0 zr1 = zc1 do k = 1 , 500 zr0 = zr0*(a+k-1.d0)*(b+k-1.d0)/(k*(a+b-c+k))*(1.d0-z) zr1 = zr1*(c-a+k-1.0_wp)*(c-b+k-1.0_wp)/(k*(c-a-b+k)) & & *(1.0_wp-z) Zhf = Zhf + zr0 + zr1 if ( abs(Zhf-zw)<abs(Zhf)*eps ) exit zw = Zhf enddo Zhf = Zhf + zc0 + zc1 endif else z00 = (1.0_wp,0.0_wp) if ( c-a<a .and. c-b<b ) then z00 = (1.0_wp-z)**(c-a-b) a = c - a b = c - b endif Zhf = (1.0_wp,0.d0) zr = (1.0_wp,0.0_wp) do k = 1 , 1500 zr = zr*(a+k-1.0_wp)*(b+k-1.0_wp)/(k*(c+k-1.0_wp))*z Zhf = Zhf + zr if ( abs(Zhf-zw)<=abs(Zhf)*eps ) exit zw = Zhf enddo Zhf = z00*Zhf endif elseif ( a0>1.0_wp ) then mab = int(a-b+eps*sign(1.0_wp,a-b)) if ( abs(a-b-mab)<eps .and. a0<=1.1_wp ) b = b + eps if ( abs(a-b-mab)>eps ) then call gamma2(a,ga) call gamma2(b,gb) call gamma2(c,gc) call gamma2(a-b,gab) call gamma2(b-a,gba) call gamma2(c-a,gca) call gamma2(c-b,gcb) zc0 = gc*gba/(gca*gb*(-z)**a) zc1 = gc*gab/(gcb*ga*(-z)**b) zr0 = zc0 zr1 = zc1 Zhf = (0.0_wp,0.0_wp) do k = 1 , 500 zr0 = zr0*(a+k-1.0_wp)*(a-c+k)/((a-b+k)*k*z) zr1 = zr1*(b+k-1.0_wp)*(b-c+k)/((b-a+k)*k*z) Zhf = Zhf + zr0 + zr1 if ( abs((Zhf-zw)/Zhf)<=eps ) exit zw = Zhf enddo Zhf = Zhf + zc0 + zc1 else if ( a-b<0.0_wp ) then a = bb b = aa endif ca = c - a cb = c - b nca = int(ca+eps*sign(1.0_wp,ca)) ncb = int(cb+eps*sign(1.0_wp,cb)) if ( abs(ca-nca)<eps .or. abs(cb-ncb)<eps ) c = c + eps call gamma2(a,ga) call gamma2(c,gc) call gamma2(c-b,gcb) call psi_spec(a,pa) call psi_spec(c-a,pca) call psi_spec(a-c,pac) mab = int(a-b+eps) zc0 = gc/(ga*(-z)**b) call gamma2(a-b,gm) zf0 = gm/gcb*zc0 zr = zc0 do k = 1 , mab - 1 zr = zr*(b+k-1.0_wp)/(k*z) t0 = a - b - k call gamma2(t0,g0) call gamma2(c-b-k,gcbk) zf0 = zf0 + zr*g0/gcbk enddo if ( mab==0 ) zf0 = (0.0_wp,0.0_wp) zc1 = gc/(ga*gcb*(-z)**a) sp = -2.0_wp*el - pa - pca do j = 1 , mab sp = sp + 1.0_wp/j enddo zp0 = sp + log(-z) sq = 1.0_wp do j = 1 , mab sq = sq*(b+j-1.0_wp)*(b-c+j)/j enddo zf1 = (sq*zp0)*zc1 zr = zc1 rk1 = 1.0_wp sj1 = 0.0_wp w0 = 0.0_wp do k = 1 , 10000 zr = zr/z rk1 = rk1*(b+k-1.0_wp)*(b-c+k)/(k*k) rk2 = rk1 do j = k + 1 , k + mab rk2 = rk2*(b+j-1.0_wp)*(b-c+j)/j enddo sj1 = sj1 + (a-1.0_wp)/(k*(a+k-1.0_wp)) + (a-c-1.0_wp) & & /(k*(a-c+k-1.0_wp)) sj2 = sj1 do j = k + 1 , k + mab sj2 = sj2 + 1.0_wp/j enddo zp = -2.0_wp*el - pa - pac + sj2 - 1.0_wp/(k+a-c) & & - pi/tan(pi*(k+a-c)) + log(-z) zf1 = zf1 + rk2*zr*zp ws = abs(zf1) if ( abs((ws-w0)/ws)<eps ) exit w0 = ws enddo Zhf = zf0 + zf1 endif endif a = aa b = bb if ( k>150 ) Isfer = 5 end subroutine itairy(x,Apt,Bpt,Ant,Bnt) ! ! ====================================================== ! Purpose: Compute the integrals of Airy fnctions with ! respect to t from 0 and x ( x ≥ 0 ) ! Input : x --- Upper limit of the integral ! Output : APT --- Integration of Ai(t) from 0 and x ! BPT --- Integration of Bi(t) from 0 and x ! ANT --- Integration of Ai(-t) from 0 and x ! BNT --- Integration of Bi(-t) from 0 and x ! ====================================================== ! implicit none real(wp) a , Ant , Apt , Bnt , Bpt , c1 , c2 , eps , fx , & & gx , q0 , q1 , q2 , r , sr3 , su1 , su2 , & & su3 , su4 real(wp) su5 , su6 , x , xe , xp6 , xr1 , xr2 integer k , l dimension a(16) eps = 1.0d-15 c1 = .355028053887817d0 c2 = .258819403792807d0 sr3 = 1.732050807568877d0 if ( x==0.0_wp ) then Apt = 0.0_wp Bpt = 0.0_wp Ant = 0.0_wp Bnt = 0.0_wp elseif ( abs(x)<=9.25d0 ) then do l = 0 , 1 x = (-1)**l*x fx = x r = x do k = 1 , 40 r = r*(3.0*k-2.0_wp)/(3.0*k+1.0_wp)*x/(3.0*k) & & *x/(3.0*k-1.0_wp)*x fx = fx + r if ( abs(r)<abs(fx)*eps ) exit enddo gx = .5d0*x*x r = gx do k = 1 , 40 r = r*(3.0*k-1.0_wp)/(3.0*k+2.0_wp)*x/(3.0*k) & & *x/(3.0*k+1.0_wp)*x gx = gx + r if ( abs(r)<abs(gx)*eps ) exit enddo Ant = c1*fx - c2*gx Bnt = sr3*(c1*fx+c2*gx) if ( l==0 ) then Apt = Ant Bpt = Bnt else Ant = -Ant Bnt = -Bnt x = -x endif enddo else data a/.569444444444444d0 , .891300154320988d0 , & & .226624344493027d+01 , .798950124766861d+01 , & & .360688546785343d+02 , .198670292131169d+03 , & & .129223456582211d+04 , .969483869669600d+04 , & & .824184704952483d+05 , .783031092490225d+06 , & & .822210493622814d+07 , .945557399360556d+08 , & & .118195595640730d+10 , .159564653040121d+11 , & & .231369166433050d+12 , .358622522796969d+13/ q2 = 1.414213562373095d0 q0 = .3333333333333333d0 q1 = .6666666666666667d0 xe = x*sqrt(x)/1.5d0 xp6 = 1.0_wp/sqrt(6.0_wp*pi*xe) su1 = 1.0_wp r = 1.0_wp xr1 = 1.0_wp/xe do k = 1 , 16 r = -r*xr1 su1 = su1 + a(k)*r enddo su2 = 1.0_wp r = 1.0_wp do k = 1 , 16 r = r*xr1 su2 = su2 + a(k)*r enddo Apt = q0 - exp(-xe)*xp6*su1 Bpt = 2.0_wp*exp(xe)*xp6*su2 su3 = 1.0_wp r = 1.0_wp xr2 = 1.0_wp/(xe*xe) do k = 1 , 8 r = -r*xr2 su3 = su3 + a(2*k)*r enddo su4 = a(1)*xr1 r = xr1 do k = 1 , 7 r = -r*xr2 su4 = su4 + a(2*k+1)*r enddo su5 = su3 + su4 su6 = su3 - su4 Ant = q1 - q2*xp6*(su5*cos(xe)-su6*sin(xe)) Bnt = q2*xp6*(su5*sin(xe)+su6*cos(xe)) endif end subroutine ikna(n,x,Nm,Bi,Di,Bk,Dk) ! ! ======================================================== ! Purpose: Compute modified Bessel functions In(x) and ! Kn(x), and their derivatives ! Input: x --- Argument of In(x) and Kn(x) ( x ≥ 0 ) ! n --- Order of In(x) and Kn(x) ! Output: BI(n) --- In(x) ! DI(n) --- In'(x) ! BK(n) --- Kn(x) ! DK(n) --- Kn'(x) ! NM --- Highest order computed ! Routines called: ! (1) IK01A for computing I0(x),I1(x),K0(x) & K1(x) ! (2) MSTA1 and MSTA2 for computing the starting ! point for backward recurrence ! ======================================================== ! implicit none real(wp) Bi , bi0 , bi1 , Bk , bk0 , bk1 , Di , di0 , & & di1 , Dk , dk0 , dk1 , f , f0 , f1 , g , g0 , & & g1 , h , h0 real(wp) h1 , s0 , x integer k , m , n , Nm dimension Bi(0:n) , Di(0:n) , Bk(0:n) , Dk(0:n) Nm = n if ( x<=1.0d-100 ) then do k = 0 , n Bi(k) = 0.0_wp Di(k) = 0.0_wp Bk(k) = 1.0e+300_wp Dk(k) = -1.0e+300_wp enddo Bi(0) = 1.0_wp Di(1) = 0.5_wp return endif call ik01a(x,bi0,di0,bi1,di1,bk0,dk0,bk1,dk1) Bi(0) = bi0 Bi(1) = bi1 Bk(0) = bk0 Bk(1) = bk1 Di(0) = di0 Di(1) = di1 Dk(0) = dk0 Dk(1) = dk1 if ( n<=1 ) return if ( x>40.0 .and. n<int(0.25*x) ) then h0 = bi0 h1 = bi1 do k = 2 , n h = -2.0_wp*(k-1.0_wp)/x*h1 + h0 Bi(k) = h h0 = h1 h1 = h enddo else m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f0 = 0.0_wp f1 = 1.0d-100 f = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)*f1/x + f0 if ( k<=Nm ) Bi(k) = f f0 = f1 f1 = f enddo s0 = bi0/f do k = 0 , Nm Bi(k) = s0*Bi(k) enddo endif g0 = bk0 g1 = bk1 do k = 2 , Nm g = 2.0_wp*(k-1.0_wp)/x*g1 + g0 Bk(k) = g g0 = g1 g1 = g enddo do k = 2 , Nm Di(k) = Bi(k-1) - k/x*Bi(k) Dk(k) = -Bk(k-1) - k/x*Bk(k) enddo end subroutine cjynb(n,z,Nm,Cbj,Cdj,Cby,Cdy) ! ! ======================================================= ! Purpose: Compute Bessel functions Jn(z), Yn(z) and ! their derivatives for a complex argument ! Input : z --- Complex argument of Jn(z) and Yn(z) ! n --- Order of Jn(z) and Yn(z) ! Output: CBJ(n) --- Jn(z) ! CDJ(n) --- Jn'(z) ! CBY(n) --- Yn(z) ! CDY(n) --- Yn'(z) ! NM --- Highest order computed ! Routines called: ! MSTA1 and MSTA2 to calculate the starting ! point for backward recurrence ! ======================================================= ! implicit none real(wp) a , a0 , a1 , b , b1 , el , r2p , y0 complex(wp) Cbj , cbj0 , cbj1 , cbjk , cbs , Cby , cby0 , cby1 , & & Cdj , Cdy , ce , cf , cf1 , cf2 , cp0 , cp1 , cq0 , & & cq1 , cs0 , csu complex(wp) csv , ct1 , ct2 , cu , cyy , z integer k , m , n , Nm dimension Cbj(0:n) , Cdj(0:n) , Cby(0:n) , Cdy(0:n) , a(4) , & & b(4) , a1(4) , b1(4) el = 0.5772156649015329d0 r2p = .63661977236758d0 y0 = abs(aimag(z)) a0 = abs(z) Nm = n if ( a0<1.0d-100 ) then do k = 0 , n Cbj(k) = (0.0_wp,0.0_wp) Cdj(k) = (0.0_wp,0.0_wp) Cby(k) = -(1.0e+300_wp,0.0_wp) Cdy(k) = (1.0e+300_wp,0.0_wp) enddo Cbj(0) = (1.0_wp,0.0_wp) Cdj(1) = (0.5_wp,0.0_wp) return endif if ( a0<=300.d0 .or. n>80 ) then if ( n==0 ) Nm = 1 m = msta1(a0,200) if ( m<Nm ) then Nm = m else m = msta2(a0,Nm,15) endif cbs = (0.0_wp,0.0_wp) csu = (0.0_wp,0.0_wp) csv = (0.0_wp,0.0_wp) cf2 = (0.0_wp,0.0_wp) cf1 = (1.0d-100,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(k+1.0_wp)/z*cf1 - cf2 if ( k<=Nm ) Cbj(k) = cf if ( k==2*int(k/2) .and. k/=0 ) then if ( y0<=1.0_wp ) then cbs = cbs + 2.0_wp*cf else cbs = cbs + (-1)**(k/2)*2.0_wp*cf endif csu = csu + (-1)**(k/2)*cf/k elseif ( k>1 ) then csv = csv + (-1)**(k/2)*k/(k*k-1.0_wp)*cf endif cf2 = cf1 cf1 = cf enddo if ( y0<=1.0_wp ) then cs0 = cbs + cf else cs0 = (cbs+cf)/cos(z) endif do k = 0 , Nm Cbj(k) = Cbj(k)/cs0 enddo ce = log(z/2.0_wp) + el Cby(0) = r2p*(ce*Cbj(0)-4.0_wp*csu/cs0) Cby(1) = r2p*(-Cbj(0)/z+(ce-1.0_wp)*Cbj(1)-4.0_wp*csv/cs0) else data a/ - .7031250000000000d-01 , .1121520996093750d+00 , & & -.5725014209747314d+00 , .6074042001273483d+01/ data b/.7324218750000000d-01 , -.2271080017089844d+00 , & & .1727727502584457d+01 , -.2438052969955606d+02/ data a1/.1171875000000000d+00 , -.1441955566406250d+00 , & & .6765925884246826d+00 , -.6883914268109947d+01/ data b1/ - .1025390625000000d+00 , .2775764465332031d+00 , & & -.1993531733751297d+01 , .2724882731126854d+02/ ct1 = z - 0.25d0*pi cp0 = (1.0_wp,0.0_wp) do k = 1 , 4 cp0 = cp0 + a(k)*z**(-2*k) enddo cq0 = -0.125d0/z do k = 1 , 4 cq0 = cq0 + b(k)*z**(-2*k-1) enddo cu = sqrt(r2p/z) cbj0 = cu*(cp0*cos(ct1)-cq0*sin(ct1)) cby0 = cu*(cp0*sin(ct1)+cq0*cos(ct1)) Cbj(0) = cbj0 Cby(0) = cby0 ct2 = z - 0.75d0*pi cp1 = (1.0_wp,0.0_wp) do k = 1 , 4 cp1 = cp1 + a1(k)*z**(-2*k) enddo cq1 = 0.375d0/z do k = 1 , 4 cq1 = cq1 + b1(k)*z**(-2*k-1) enddo cbj1 = cu*(cp1*cos(ct2)-cq1*sin(ct2)) cby1 = cu*(cp1*sin(ct2)+cq1*cos(ct2)) Cbj(1) = cbj1 Cby(1) = cby1 do k = 2 , Nm cbjk = 2.0_wp*(k-1.0_wp)/z*cbj1 - cbj0 Cbj(k) = cbjk cbj0 = cbj1 cbj1 = cbjk enddo endif Cdj(0) = -Cbj(1) do k = 1 , Nm Cdj(k) = Cbj(k-1) - k/z*Cbj(k) enddo if ( abs(Cbj(0))>1.0_wp ) Cby(1) = (Cbj(1)*Cby(0)-2.0_wp/(pi*z)) & & /Cbj(0) do k = 2 , Nm if ( abs(Cbj(k-1))>=abs(Cbj(k-2)) ) then cyy = (Cbj(k)*Cby(k-1)-2.0_wp/(pi*z))/Cbj(k-1) else cyy = (Cbj(k)*Cby(k-2)-4.0_wp*(k-1.0_wp)/(pi*z*z))/Cbj(k-2) endif Cby(k) = cyy enddo Cdy(0) = -Cby(1) do k = 1 , Nm Cdy(k) = Cby(k-1) - k/z*Cby(k) enddo end subroutine iknb(n,x,Nm,Bi,Di,Bk,Dk) ! ! ============================================================ ! Purpose: Compute modified Bessel functions In(x) and Kn(x), ! and their derivatives ! Input: x --- Argument of In(x) and Kn(x) ( 0 ≤ x ≤ 700 ) ! n --- Order of In(x) and Kn(x) ! Output: BI(n) --- In(x) ! DI(n) --- In'(x) ! BK(n) --- Kn(x) ! DK(n) --- Kn'(x) ! NM --- Highest order computed ! Routines called: ! MSTA1 and MSTA2 for computing the starting point ! for backward recurrence ! =========================================================== ! implicit none real(wp) a0 , Bi , Bk , bkl , bs , Di , Dk , el , f , f0 ,& & f1 , g , g0 , g1 , r , s0 , sk0 , vt , x integer k , k0 , l , m , n , Nm dimension Bi(0:n) , Di(0:n) , Bk(0:n) , Dk(0:n) el = 0.5772156649015329d0 Nm = n if ( x<=1.0d-100 ) then do k = 0 , n Bi(k) = 0.0_wp Di(k) = 0.0_wp Bk(k) = 1.0e+300_wp Dk(k) = -1.0e+300_wp enddo Bi(0) = 1.0_wp Di(1) = 0.5_wp return endif if ( n==0 ) Nm = 1 m = msta1(x,200) if ( m<Nm ) then Nm = m else m = msta2(x,Nm,15) endif bs = 0.0_wp sk0 = 0.0_wp f = 0.0_wp f0 = 0.0_wp f1 = 1.0d-100 do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)/x*f1 + f0 if ( k<=Nm ) Bi(k) = f if ( k/=0 .and. k==2*int(k/2) ) sk0 = sk0 + 4.0_wp*f/k bs = bs + 2.0_wp*f f0 = f1 f1 = f enddo s0 = exp(x)/(bs-f) do k = 0 , Nm Bi(k) = s0*Bi(k) enddo if ( x<=8.0_wp ) then Bk(0) = -(log(0.5_wp*x)+el)*Bi(0) + s0*sk0 Bk(1) = (1.0_wp/x-Bi(1)*Bk(0))/Bi(0) else a0 = sqrt(pi/(2.0_wp*x))*exp(-x) k0 = 16 if ( x>=25.0 ) k0 = 10 if ( x>=80.0 ) k0 = 8 if ( x>=200.0 ) k0 = 6 do l = 0 , 1 bkl = 1.0_wp vt = 4.0_wp*l r = 1.0_wp do k = 1 , k0 r = 0.125d0*r*(vt-(2.0*k-1.0)**2)/(k*x) bkl = bkl + r enddo Bk(l) = a0*bkl enddo endif g0 = Bk(0) g1 = Bk(1) do k = 2 , Nm g = 2.0_wp*(k-1.0_wp)/x*g1 + g0 Bk(k) = g g0 = g1 g1 = g enddo Di(0) = Bi(1) Dk(0) = -Bk(1) do k = 1 , Nm Di(k) = Bi(k-1) - k/x*Bi(k) Dk(k) = -Bk(k-1) - k/x*Bk(k) enddo end subroutine lpmn(Mm,m,n,x,Pm,Pd) ! ! ===================================================== ! Purpose: Compute the associated Legendre functions ! Pmn(x) and their derivatives Pmn'(x) for ! real argument ! Input : x --- Argument of Pmn(x) ! m --- Order of Pmn(x), m = 0,1,2,...,n ! n --- Degree of Pmn(x), n = 0,1,2,...,N ! mm --- Physical dimension of PM and PD ! Output: PM(m,n) --- Pmn(x) ! PD(m,n) --- Pmn'(x) ! ===================================================== ! implicit none real(wp) Pd , Pm , x , xq , xs integer i , j , ls , m , Mm , n dimension Pm(0:Mm,0:n) , Pd(0:Mm,0:n) intrinsic min do i = 0 , n do j = 0 , m Pm(j,i) = 0.0_wp Pd(j,i) = 0.0_wp enddo enddo Pm(0,0) = 1.0_wp if ( n==0 ) return if ( abs(x)==1.0_wp ) then do i = 1 , n Pm(0,i) = x**i Pd(0,i) = 0.5_wp*i*(i+1.0_wp)*x**(i+1) enddo do j = 1 , n do i = 1 , m if ( i==1 ) then Pd(i,j) = dinf() elseif ( i==2 ) then Pd(i,j) = -0.25d0*(j+2)*(j+1)*j*(j-1)*x**(j+1) endif enddo enddo return endif ls = 1 if ( abs(x)>1.0_wp ) ls = -1 xq = sqrt(ls*(1.0_wp-x*x)) ! Ensure connection to the complex-valued function for |x| > 1 if ( x<-1d0 ) xq = -xq xs = ls*(1.0_wp-x*x) do i = 1 , m Pm(i,i) = -ls*(2.0_wp*i-1.0_wp)*xq*Pm(i-1,i-1) enddo do i = 0 , min(m,n-1) Pm(i,i+1) = (2.0_wp*i+1.0_wp)*x*Pm(i,i) enddo do i = 0 , m do j = i + 2 , n Pm(i,j) = ((2.0_wp*j-1.0_wp)*x*Pm(i,j-1)-(i+j-1.0_wp)*Pm(i,j-2)& & )/(j-i) enddo enddo Pd(0,0) = 0.0_wp do j = 1 , n Pd(0,j) = ls*j*(Pm(0,j-1)-x*Pm(0,j))/xs enddo do i = 1 , m do j = i , n Pd(i,j) = ls*i*x*Pm(i,j)/xs + (j+i)*(j-i+1.0_wp)/xq*Pm(i-1,j) enddo enddo end subroutine mtu0(Kf,m,q,x,Csf,Csd) ! ! =============================================================== ! Purpose: Compute Mathieu functions cem(x,q) and sem(x,q) ! and their derivatives ( q ≥ 0 ) ! Input : KF --- Function code ! KF=1 for computing cem(x,q) and cem'(x,q) ! KF=2 for computing sem(x,q) and sem'(x,q) ! m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! x --- Argument of Mathieu functions (in degrees) ! Output: CSF --- cem(x,q) or sem(x,q) ! CSD --- cem'x,q) or sem'x,q) ! Routines called: ! (1) CVA2 for computing the characteristic values ! (2) FCOEF for computing the expansion coefficients ! =============================================================== ! implicit none real(wp) a , Csd , Csf , eps , fg , q , qm , rd , & & x , xr integer ic , k , kd , Kf , km , m dimension fg(251) eps = 1.0d-14 if ( Kf==1 .and. m==2*int(m/2) ) kd = 1 if ( Kf==1 .and. m/=2*int(m/2) ) kd = 2 if ( Kf==2 .and. m/=2*int(m/2) ) kd = 3 if ( Kf==2 .and. m==2*int(m/2) ) kd = 4 call cva2(kd,m,q,a) if ( q<=1.0_wp ) then qm = 7.5 + 56.1*sqrt(q) - 134.7*q + 90.7*sqrt(q)*q else qm = 17.0 + 3.1*sqrt(q) - .126*q + .0037*sqrt(q)*q endif km = int(qm+0.5*m) if ( km>251 ) then Csf = dnan() Csd = dnan() return endif call fcoef(kd,m,q,a,fg) ic = int(m/2) + 1 rd = 1.74532925199433d-2 xr = x*rd Csf = 0.0_wp do k = 1 , km if ( kd==1 ) then Csf = Csf + fg(k)*cos((2*k-2)*xr) elseif ( kd==2 ) then Csf = Csf + fg(k)*cos((2*k-1)*xr) elseif ( kd==3 ) then Csf = Csf + fg(k)*sin((2*k-1)*xr) elseif ( kd==4 ) then Csf = Csf + fg(k)*sin(2*k*xr) endif if ( k>=ic .and. abs(fg(k))<abs(Csf)*eps ) exit enddo Csd = 0.0_wp do k = 1 , km if ( kd==1 ) then Csd = Csd - (2*k-2)*fg(k)*sin((2*k-2)*xr) elseif ( kd==2 ) then Csd = Csd - (2*k-1)*fg(k)*sin((2*k-1)*xr) elseif ( kd==3 ) then Csd = Csd + (2*k-1)*fg(k)*cos((2*k-1)*xr) elseif ( kd==4 ) then Csd = Csd + 2.0_wp*k*fg(k)*cos(2*k*xr) endif if ( k>=ic .and. abs(fg(k))<abs(Csd)*eps ) exit enddo end subroutine cy01(Kf,z,Zf,Zd) ! ! =========================================================== ! Purpose: Compute complex Bessel functions Y0(z), Y1(z) ! and their derivatives ! Input : z --- Complex argument of Yn(z) ( n=0,1 ) ! KF --- Function choice code ! KF=0 for ZF=Y0(z) and ZD=Y0'(z) ! KF=1 for ZF=Y1(z) and ZD=Y1'(z) ! KF=2 for ZF=Y1'(z) and ZD=Y1''(z) ! Output: ZF --- Y0(z) or Y1(z) or Y1'(z) ! ZD --- Y0'(z) or Y1'(z) or Y1''(z) ! =========================================================== ! implicit none real(wp) a , a0 , a1 , b , b1 , el , rp2 , w0 , w1 complex(wp) cbj0 , cbj1 , cby0 , cby1 , cdy0 , cdy1 , ci , cp , & & cp0 , cp1 , cq0 , cq1 , cr , cs , ct1 , ct2 , cu , z , & & z1 , z2 complex(wp) Zd , Zf integer k , k0 , Kf dimension a(12) , b(12) , a1(12) , b1(12) el = 0.5772156649015329d0 rp2 = 2.0_wp/pi ci = (0.0_wp,1.0_wp) a0 = abs(z) z2 = z*z z1 = z if ( a0==0.0_wp ) then cbj0 = (1.0_wp,0.0_wp) cbj1 = (0.0_wp,0.0_wp) cby0 = -(1.0d300,0.0_wp) cby1 = -(1.0d300,0.0_wp) cdy0 = (1.0d300,0.0_wp) cdy1 = (1.0d300,0.0_wp) goto 300 endif if ( real(z,wp)<0.0 ) z1 = -z if ( a0<=12.0 ) then cbj0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25d0*cr*z2/(k*k) cbj0 = cbj0 + cr if ( abs(cr)<abs(cbj0)*1.0d-15 ) exit enddo cbj1 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 40 cr = -0.25d0*cr*z2/(k*(k+1.0_wp)) cbj1 = cbj1 + cr if ( abs(cr)<abs(cbj1)*1.0d-15 ) exit enddo cbj1 = 0.5_wp*z1*cbj1 w0 = 0.0_wp cr = (1.0_wp,0.0_wp) cs = (0.0_wp,0.0_wp) do k = 1 , 40 w0 = w0 + 1.0_wp/k cr = -0.25d0*cr/(k*k)*z2 cp = cr*w0 cs = cs + cp if ( abs(cp)<abs(cs)*1.0d-15 ) exit enddo cby0 = rp2*(log(z1/2.0_wp)+el)*cbj0 - rp2*cs w1 = 0.0_wp cr = (1.0_wp,0.0_wp) cs = (1.0_wp,0.0_wp) do k = 1 , 40 w1 = w1 + 1.0_wp/k cr = -0.25d0*cr/(k*(k+1))*z2 cp = cr*(2.0_wp*w1+1.0_wp/(k+1.0_wp)) cs = cs + cp if ( abs(cp)<abs(cs)*1.0d-15 ) exit enddo cby1 = rp2*((log(z1/2.0_wp)+el)*cbj1-1.0_wp/z1-0.25_wp*z1*cs) else data a/ - .703125d-01 , .112152099609375d+00 , & & -.5725014209747314d+00 , .6074042001273483d+01 , & & -.1100171402692467d+03 , .3038090510922384d+04 , & & -.1188384262567832d+06 , .6252951493434797d+07 , & & -.4259392165047669d+09 , .3646840080706556d+11 , & & -.3833534661393944d+13 , .4854014686852901d+15/ data b/.732421875d-01 , -.2271080017089844d+00 , & & .1727727502584457d+01 , -.2438052969955606d+02 , & & .5513358961220206d+03 , -.1825775547429318d+05 , & & .8328593040162893d+06 , -.5006958953198893d+08 , & & .3836255180230433d+10 , -.3649010818849833d+12 , & & .4218971570284096d+14 , -.5827244631566907d+16/ data a1/.1171875d+00 , -.144195556640625d+00 , & & .6765925884246826d+00 , -.6883914268109947d+01 , & & .1215978918765359d+03 , -.3302272294480852d+04 , & & .1276412726461746d+06 , -.6656367718817688d+07 , & & .4502786003050393d+09 , -.3833857520742790d+11 , & & .4011838599133198d+13 , -.5060568503314727d+15/ data b1/ - .1025390625d+00 , .2775764465332031d+00 , & & -.1993531733751297d+01 , .2724882731126854d+02 , & & -.6038440767050702d+03 , .1971837591223663d+05 , & & -.8902978767070678d+06 , .5310411010968522d+08 , & & -.4043620325107754d+10 , .3827011346598605d+12 , & & -.4406481417852278d+14 , .6065091351222699d+16/ k0 = 12 if ( a0>=35.0 ) k0 = 10 if ( a0>=50.0 ) k0 = 8 ct1 = z1 - .25d0*pi cp0 = (1.0_wp,0.0_wp) do k = 1 , k0 cp0 = cp0 + a(k)*z1**(-2*k) enddo cq0 = -0.125d0/z1 do k = 1 , k0 cq0 = cq0 + b(k)*z1**(-2*k-1) enddo cu = sqrt(rp2/z1) cbj0 = cu*(cp0*cos(ct1)-cq0*sin(ct1)) cby0 = cu*(cp0*sin(ct1)+cq0*cos(ct1)) ct2 = z1 - .75d0*pi cp1 = (1.0_wp,0.0_wp) do k = 1 , k0 cp1 = cp1 + a1(k)*z1**(-2*k) enddo cq1 = 0.375d0/z1 do k = 1 , k0 cq1 = cq1 + b1(k)*z1**(-2*k-1) enddo cbj1 = cu*(cp1*cos(ct2)-cq1*sin(ct2)) cby1 = cu*(cp1*sin(ct2)+cq1*cos(ct2)) endif if ( real(z,wp)<0.0 ) then if ( aimag(z)<0.0 ) cby0 = cby0 - 2.0_wp*ci*cbj0 if ( aimag(z)>0.0 ) cby0 = cby0 + 2.0_wp*ci*cbj0 if ( aimag(z)<0.0 ) cby1 = -(cby1-2.0_wp*ci*cbj1) if ( aimag(z)>0.0 ) cby1 = -(cby1+2.0_wp*ci*cbj1) cbj1 = -cbj1 endif cdy0 = -cby1 cdy1 = cby0 - 1.0_wp/z*cby1 300 if ( Kf==0 ) then Zf = cby0 Zd = cdy0 elseif ( Kf==1 ) then Zf = cby1 Zd = cdy1 elseif ( Kf==2 ) then Zf = cdy1 Zd = -cdy1/z - (1.0_wp-1.0_wp/(z*z))*cby1 endif end subroutine ffk(Ks,x,Fr,Fi,Fm,Fa,Gr,Gi,Gm,Ga) ! ! ======================================================= ! Purpose: Compute modified Fresnel integrals F±(x) ! and K±(x) ! Input : x --- Argument of F±(x) and K±(x) ! KS --- Sign code ! KS=0 for calculating F+(x) and K+(x) ! KS=1 for calculating F_(x) and K_(x) ! Output: FR --- Re[F±(x)] ! FI --- Im[F±(x)] ! FM --- |F±(x)| ! FA --- Arg[F±(x)] (Degs.) ! GR --- Re[K±(x)] ! GI --- Im[K±(x)] ! GM --- |K±(x)| ! GA --- Arg[K±(x)] (Degs.) ! ====================================================== ! implicit none real(wp) c1 , cs , eps , Fa , Fi , fi0 , Fm , Fr , Ga , & & Gi , Gm , Gr , p2p , pp2 , s1 , srd , ss , & & x , x2 real(wp) x4 , xa , xc , xf , xf0 , xf1 , xg , xp , xq , & & xq2 , xr , xs , xsu , xw integer k , Ks , m srd = 57.29577951308233d0 eps = 1.0d-15 pp2 = 1.2533141373155d0 p2p = .7978845608028654d0 xa = abs(x) x2 = x*x x4 = x2*x2 if ( x==0.0_wp ) then Fr = .5d0*sqrt(halfpi) Fi = (-1)**Ks*Fr Fm = sqrt(0.25d0*pi) Fa = (-1)**Ks*45.0d0 Gr = .5d0 Gi = 0.0_wp Gm = .5d0 Ga = 0.0_wp else if ( xa<=2.5d0 ) then xr = p2p*xa c1 = xr do k = 1 , 50 xr = -0.5_wp*xr*(4.0_wp*k-3.0_wp)/k/(2.0_wp*k-1.0_wp) & & /(4.0_wp*k+1.0_wp)*x4 c1 = c1 + xr if ( abs(xr/c1)<eps ) exit enddo s1 = p2p*xa*xa*xa/3.0_wp xr = s1 do k = 1 , 50 xr = -0.5_wp*xr*(4.0_wp*k-1.0_wp)/k/(2.0_wp*k+1.0_wp) & & /(4.0_wp*k+3.0_wp)*x4 s1 = s1 + xr if ( abs(xr/s1)<eps ) goto 50 enddo elseif ( xa<5.5d0 ) then m = int(42+1.75*x2) xsu = 0.0_wp xc = 0.0_wp xs = 0.0_wp xf1 = 0.0_wp xf0 = 1d-100 do k = m , 0 , -1 xf = (2.0_wp*k+3.0_wp)*xf0/x2 - xf1 if ( k==2*int(k/2) ) then xc = xc + xf else xs = xs + xf endif xsu = xsu + (2.0_wp*k+1.0_wp)*xf*xf xf1 = xf0 xf0 = xf enddo xq = sqrt(xsu) xw = p2p*xa/xq c1 = xc*xw s1 = xs*xw else xr = 1.0_wp xf = 1.0_wp do k = 1 , 12 xr = -0.25_wp*xr*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/x4 xf = xf + xr enddo xr = 1.0_wp/(2.0_wp*xa*xa) xg = xr do k = 1 , 12 xr = -0.25_wp*xr*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/x4 xg = xg + xr enddo c1 = .5d0 + (xf*sin(x2)-xg*cos(x2))/sqrt(2.0_wp*pi)/xa s1 = .5d0 - (xf*cos(x2)+xg*sin(x2))/sqrt(2.0_wp*pi)/xa endif 50 Fr = pp2*(0.5_wp-c1) fi0 = pp2*(0.5_wp-s1) Fi = (-1)**Ks*fi0 Fm = sqrt(Fr*Fr+Fi*Fi) if ( Fr>=0.0 ) then Fa = srd*atan(Fi/Fr) elseif ( Fi>0.0 ) then Fa = srd*(atan(Fi/Fr)+pi) elseif ( Fi<0.0 ) then Fa = srd*(atan(Fi/Fr)-pi) endif xp = x*x + pi/4.0_wp cs = cos(xp) ss = sin(xp) xq2 = 1.0_wp/sqrtpi Gr = xq2*(Fr*cs+fi0*ss) Gi = (-1)**Ks*xq2*(fi0*cs-Fr*ss) Gm = sqrt(Gr*Gr+Gi*Gi) if ( Gr>=0.0 ) then Ga = srd*atan(Gi/Gr) elseif ( Gi>0.0 ) then Ga = srd*(atan(Gi/Gr)+pi) elseif ( Gi<0.0 ) then Ga = srd*(atan(Gi/Gr)-pi) endif if ( x<0.0_wp ) then Fr = pp2 - Fr Fi = (-1)**Ks*pp2 - Fi Fm = sqrt(Fr*Fr+Fi*Fi) Fa = srd*atan(Fi/Fr) Gr = cos(x*x) - Gr Gi = -(-1)**Ks*sin(x*x) - Gi Gm = sqrt(Gr*Gr+Gi*Gi) Ga = srd*atan(Gi/Gr) endif endif end subroutine airya(x,Ai,Bi,Ad,Bd) ! ! ====================================================== ! Purpose: Compute Airy functions and their derivatives ! Input: x --- Argument of Airy function ! Output: AI --- Ai(x) ! BI --- Bi(x) ! AD --- Ai'(x) ! BD --- Bi'(x) ! Routine called: ! AJYIK for computing Jv(x), Yv(x), Iv(x) and ! Kv(x) with v=1/3 and 2/3 ! ====================================================== ! implicit none real(wp) Ad , Ai , Bd , Bi , c1 , c2 , pir , sr3 , vi1 , & & vi2 , vj1 , vj2 , vk1 , vk2 , vy1 , vy2 , x , & & xa , xq , z xa = abs(x) pir = 0.318309886183891d0 c1 = 0.355028053887817d0 c2 = 0.258819403792807d0 sr3 = 1.732050807568877d0 z = xa**1.5/1.5d0 xq = sqrt(xa) call ajyik(z,vj1,vj2,vy1,vy2,vi1,vi2,vk1,vk2) if ( x==0.0_wp ) then Ai = c1 Bi = sr3*c1 Ad = -c2 Bd = sr3*c2 elseif ( x>0.0_wp ) then Ai = pir*xq/sr3*vk1 Bi = xq*(pir*vk1+2.0_wp/sr3*vi1) Ad = -xa/sr3*pir*vk2 Bd = xa*(pir*vk2+2.0_wp/sr3*vi2) else Ai = 0.5_wp*xq*(vj1-vy1/sr3) Bi = -0.5_wp*xq*(vj1/sr3+vy1) Ad = 0.5_wp*xa*(vj2+vy2/sr3) Bd = 0.5_wp*xa*(vj2/sr3-vy2) endif end subroutine airyb(x,Ai,Bi,Ad,Bd) ! ! ======================================================= ! Purpose: Compute Airy functions and their derivatives ! Input: x --- Argument of Airy function ! Output: AI --- Ai(x) ! BI --- Bi(x) ! AD --- Ai'(x) ! BD --- Bi'(x) ! ======================================================= ! implicit none real(wp) Ad , Ai , Bd , Bi , c1 , c2 , ck , df , dg , dk ,& & eps , fx , gx , r , rp , sad , sai , sbd , & & sbi real(wp) sda , sdb , sr3 , ssa , ssb , x , xa , xar , & & xcs , xe , xf , xm , xp1 , xq , xr1 , xr2 , xss integer k , km , km2 , kmax dimension ck(51) , dk(51) eps = 1.0d-15 c1 = 0.355028053887817d0 c2 = 0.258819403792807d0 sr3 = 1.732050807568877d0 xa = abs(x) xq = sqrt(xa) xm = 8.0_wp if ( x>0.0_wp ) xm = 5.0_wp if ( x==0.0_wp ) then Ai = c1 Bi = sr3*c1 Ad = -c2 Bd = sr3*c2 return endif if ( xa<=xm ) then fx = 1.0_wp r = 1.0_wp do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k-1.0_wp)*x fx = fx + r if ( abs(r)<abs(fx)*eps ) exit enddo gx = x r = x do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k+1.0_wp)*x gx = gx + r if ( abs(r)<abs(gx)*eps ) exit enddo Ai = c1*fx - c2*gx Bi = sr3*(c1*fx+c2*gx) df = 0.5_wp*x*x r = df do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k+2.0_wp)*x df = df + r if ( abs(r)<abs(df)*eps ) exit enddo dg = 1.0_wp r = 1.0_wp do k = 1 , 40 r = r*x/(3.0_wp*k)*x/(3.0_wp*k-2.0_wp)*x dg = dg + r if ( abs(r)<abs(dg)*eps ) exit enddo Ad = c1*df - c2*dg Bd = sr3*(c1*df+c2*dg) else km = int(24.5-xa) if ( xa<6.0 ) km = 14 if ( xa>15.0 ) km = 10 if ( x>0.0_wp ) then kmax = km else ! Choose cutoffs so that the remainder term in asymptotic ! expansion is epsilon size. The X<0 branch needs to be fast ! in order to make AIRYZO efficient if ( xa>70.0 ) km = 3 if ( xa>500.0 ) km = 2 if ( xa>1000.0 ) km = 1 km2 = km if ( xa>150.0 ) km2 = 1 if ( xa>3000.0 ) km2 = 0 kmax = 2*km + 1 endif xe = xa*xq/1.5d0 xr1 = 1.0_wp/xe xar = 1.0_wp/xq xf = sqrt(xar) rp = 0.5641895835477563d0 r = 1.0_wp do k = 1 , kmax r = r*(6.0_wp*k-1.0_wp)/216.0d0*(6.0_wp*k-3.0_wp) & & /k*(6.0_wp*k-5.0_wp)/(2.0_wp*k-1.0_wp) ck(k) = r dk(k) = -(6.0_wp*k+1.0_wp)/(6.0_wp*k-1.0_wp)*ck(k) enddo if ( x>0.0_wp ) then sai = 1.0_wp sad = 1.0_wp r = 1.0_wp do k = 1 , km r = -r*xr1 sai = sai + ck(k)*r sad = sad + dk(k)*r enddo sbi = 1.0_wp sbd = 1.0_wp r = 1.0_wp do k = 1 , km r = r*xr1 sbi = sbi + ck(k)*r sbd = sbd + dk(k)*r enddo xp1 = exp(-xe) Ai = 0.5_wp*rp*xf*xp1*sai Bi = rp*xf/xp1*sbi Ad = -0.5_wp*rp/xf*xp1*sad Bd = rp/xf/xp1*sbd else xcs = cos(xe+pi/4.0_wp) xss = sin(xe+pi/4.0_wp) ssa = 1.0_wp sda = 1.0_wp r = 1.0_wp xr2 = 1.0_wp/(xe*xe) do k = 1 , km r = -r*xr2 ssa = ssa + ck(2*k)*r sda = sda + dk(2*k)*r enddo ssb = ck(1)*xr1 sdb = dk(1)*xr1 r = xr1 do k = 1 , km2 r = -r*xr2 ssb = ssb + ck(2*k+1)*r sdb = sdb + dk(2*k+1)*r enddo Ai = rp*xf*(xss*ssa-xcs*ssb) Bi = rp*xf*(xcs*ssa+xss*ssb) Ad = -rp/xf*(xcs*sda+xss*sdb) Bd = rp/xf*(xss*sda-xcs*sdb) endif endif end subroutine scka(m,n,c,Cv,Kd,Ck) ! ! ====================================================== ! Purpose: Compute the expansion coefficients of the ! prolate and oblate spheroidal functions, c2k ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! cv --- Characteristic value ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! Output: CK(k) --- Expansion coefficients ck; ! CK(1), CK(2),... correspond to ! c0, c2,... ! ====================================================== ! implicit none real(wp) c , Ck , cs , Cv , f , f0 , f1 , f2 , fl , fs , & & r1 , r2 , s0 , su1 , su2 integer ip , j , k , k1 , kb , Kd , m , n , nm dimension Ck(200) if ( c<=1.0d-10 ) c = 1.0d-10 nm = 25 + int((n-m)/2+c) cs = c*c*Kd ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 fs = 1.0_wp f1 = 0.0_wp f0 = 1.0d-100 kb = 0 Ck(nm+1) = 0.0_wp fl = 0.0_wp do k = nm , 1 , -1 f = (((2.0_wp*k+m+ip)*(2.0_wp*k+m+1.0_wp+ip)-Cv+cs) & & *f0-4.0_wp*(k+1.0_wp)*(k+m+1.0_wp)*f1)/cs if ( abs(f)>abs(Ck(k+1)) ) then Ck(k) = f f1 = f0 f0 = f if ( abs(f)>1.0d+100 ) then do k1 = nm , k , -1 Ck(k1) = Ck(k1)*1.0d-100 enddo f1 = f1*1.0d-100 f0 = f0*1.0d-100 endif else kb = k fl = Ck(k+1) f1 = 1.0_wp f2 = 0.25d0*((m+ip)*(m+ip+1.0)-Cv+cs)/(m+1.0)*f1 Ck(1) = f1 if ( kb==1 ) then fs = f2 elseif ( kb==2 ) then Ck(2) = f2 fs = 0.125d0*(((m+ip+2.0)*(m+ip+3.0)-Cv+cs)*f2-cs*f1) & & /(m+2.0) else Ck(2) = f2 do j = 3 , kb + 1 f = 0.25d0*(((2.0*j+m+ip-4.0)*(2.0*j+m+ip-3.0)-Cv+cs) & & *f2-cs*f1)/((j-1.0)*(j+m-1.0)) if ( j<=kb ) Ck(j) = f f1 = f2 f2 = f enddo fs = f endif goto 100 endif enddo 100 su1 = 0.0_wp do k = 1 , kb su1 = su1 + Ck(k) enddo su2 = 0.0_wp do k = kb + 1 , nm su2 = su2 + Ck(k) enddo r1 = 1.0_wp do j = 1 , (n+m+ip)/2 r1 = r1*(j+0.5_wp*(n+m+ip)) enddo r2 = 1.0_wp do j = 1 , (n-m-ip)/2 r2 = -r2*j enddo if ( kb==0 ) then s0 = r1/(2.0_wp**n*r2*su2) else s0 = r1/(2.0_wp**n*r2*(fl/fs*su1+su2)) endif do k = 1 , kb Ck(k) = fl/fs*s0*Ck(k) enddo do k = kb + 1 , nm Ck(k) = s0*Ck(k) enddo end subroutine sckb(m,n,c,Df,Ck) ! ! ====================================================== ! Purpose: Compute the expansion coefficients of the ! prolate and oblate spheroidal functions ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! DF(k) --- Expansion coefficients dk ! Output: CK(k) --- Expansion coefficients ck; ! CK(1), CK(2), ... correspond to ! c0, c2, ... ! ====================================================== ! implicit none real(wp) c , Ck , d1 , d2 , d3 , Df , fac , r , r1 , reg ,& & sum , sw integer i , i1 , i2 , ip , k , m , n , nm dimension Df(200) , Ck(200) if ( c<=1.0d-10 ) c = 1.0d-10 nm = 25 + int(0.5*(n-m)+c) ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 reg = 1.0_wp if ( m+nm>80 ) reg = 1.0d-200 fac = -0.5_wp**m sw = 0.0_wp do k = 0 , nm - 1 fac = -fac i1 = 2*k + ip + 1 r = reg do i = i1 , i1 + 2*m - 1 r = r*i enddo i2 = k + m + ip do i = i2 , i2 + k - 1 r = r*(i+0.5_wp) enddo sum = r*Df(k+1) do i = k + 1 , nm d1 = 2.0_wp*i + ip d2 = 2.0_wp*m + d1 d3 = i + m + ip - 0.5_wp r = r*d2*(d2-1.0_wp)*i*(d3+k)/(d1*(d1-1.0_wp)*(i-k)*d3) sum = sum + r*Df(i+1) if ( abs(sw-sum)<abs(sum)*1.0d-14 ) exit sw = sum enddo r1 = reg do i = 2 , m + k r1 = r1*i enddo Ck(k+1) = fac*sum/r1 enddo end subroutine cpdla(n,z,Cdn) ! ! =========================================================== ! Purpose: Compute complex parabolic cylinder function Dn(z) ! for large argument ! Input: z --- Complex argument of Dn(z) ! n --- Order of Dn(z) (n = 0,±1,±2,…) ! Output: CDN --- Dn(z) ! =========================================================== ! implicit none complex(wp) cb0 , Cdn , cr , z integer k , n cb0 = z**n*exp(-0.25_wp*z*z) cr = (1.0_wp,0.0_wp) Cdn = (1.0_wp,0.0_wp) do k = 1 , 16 cr = -0.5_wp*cr*(2.0*k-n-1.0)*(2.0*k-n-2.0)/(k*z*z) Cdn = Cdn + cr if ( abs(cr)<abs(Cdn)*1.0d-12 ) exit enddo Cdn = cb0*Cdn end subroutine fcszo(Kf,Nt,Zo) ! ! =============================================================== ! Purpose: Compute the complex zeros of Fresnel integral C(z) ! or S(z) using modified Newton's iteration method ! Input : KF --- Function code ! KF=1 for C(z) or KF=2 for S(z) ! NT --- Total number of zeros ! Output: ZO(L) --- L-th zero of C(z) or S(z) ! Routines called: ! (1) CFC for computing Fresnel integral C(z) ! (2) CFS for computing Fresnel integral S(z) ! ============================================================== ! implicit none integer i , it , j , Kf , nr , Nt real(wp) psq , px , py , w , w0 complex(wp) z , zd , zf , zfd , zgd , Zo , zp , zq , zw dimension Zo(Nt) psq = 0.0_wp w = 0.0_wp do nr = 1 , Nt if ( Kf==1 ) psq = sqrt(4.0_wp*nr-1.0_wp) if ( Kf==2 ) psq = 2.0_wp*nr**(0.5) px = psq - log(pi*psq)/(pi*pi*psq**3.0) py = log(pi*psq)/(pi*psq) z = dcmplx(px,py) if ( Kf==2 ) then if ( nr==2 ) z = (2.8334,0.2443) if ( nr==3 ) z = (3.4674,0.2185) if ( nr==4 ) z = (4.0025,0.2008) endif it = 0 50 it = it + 1 if ( Kf==1 ) call cfc(z,zf,zd) if ( Kf==2 ) call cfs(z,zf,zd) zp = (1.0_wp,0.0_wp) do i = 1 , nr - 1 zp = zp*(z-Zo(i)) enddo zfd = zf/zp zq = (0.0_wp,0.0_wp) do i = 1 , nr - 1 zw = (1.0_wp,0.0_wp) do j = 1 , nr - 1 if ( j/=i ) zw = zw*(z-Zo(j)) enddo zq = zq + zw enddo zgd = (zd-zq*zfd)/zp z = z - zfd/zgd w0 = w w = abs(z) if ( it<=50 .and. abs((w-w0)/w)>1.0d-12 ) goto 50 Zo(nr) = z enddo end subroutine e1xa(x,e1) ! ! ============================================ ! Purpose: Compute exponential integral E1(x) ! Input : x --- Argument of E1(x) ! Output: E1 --- E1(x) ( x > 0 ) ! ============================================ ! implicit none real(wp) e1 , es1 , es2 , x if ( x==0.0 ) then e1 = 1.0e+300_wp elseif ( x<=1.0 ) then e1 = -log(x) + ((((1.07857d-3*x-9.76004d-3)*x+5.519968d-2)*x- & & 0.24991055d0)*x+0.99999193d0)*x - 0.57721566d0 else es1 = (((x+8.5733287401d0)*x+18.059016973d0)*x+8.6347608925d0) & & *x + 0.2677737343d0 es2 = (((x+9.5733223454d0)*x+25.6329561486d0) & & *x+21.0996530827d0)*x + 3.9584969228d0 e1 = exp(-x)/x*es1/es2 endif end subroutine lpmv0(v,m,x,Pmv) ! ! ======================================================= ! Purpose: Compute the associated Legendre function ! Pmv(x) with an integer order and an arbitrary ! nonnegative degree v ! Input : x --- Argument of Pm(x) ( -1 ≤ x ≤ 1 ) ! m --- Order of Pmv(x) ! v --- Degree of Pmv(x) ! Output: PMV --- Pmv(x) ! Routine called: PSI_SPEC for computing Psi function ! ======================================================= ! implicit none real(wp) c0 , el , eps , pa , Pmv , pss , psv , pv0 ,& & qr , r , r0 , r1 , r2 , rg , s , s0 , s1 , s2 , v real(wp) v0 , vs , x , xq integer j , k , m , nv el = .5772156649015329d0 eps = 1.0d-14 nv = int(v) v0 = v - nv if ( x==-1.0_wp .and. v/=nv ) then if ( m==0 ) Pmv = -1.0e+300_wp if ( m/=0 ) Pmv = 1.0e+300_wp return endif c0 = 1.0_wp if ( m/=0 ) then rg = v*(v+m) do j = 1 , m - 1 rg = rg*(v*v-j*j) enddo xq = sqrt(1.0_wp-x*x) r0 = 1.0_wp do j = 1 , m r0 = .5d0*r0*xq/j enddo c0 = r0*rg endif if ( v0==0.0_wp ) then ! DLMF 14.3.4, 14.7.17, 15.2.4 Pmv = 1.0_wp r = 1.0_wp do k = 1 , nv - m r = 0.5_wp*r*(-nv+m+k-1.0_wp)*(nv+m+k)/(k*(k+m))*(1.0_wp+x) Pmv = Pmv + r enddo Pmv = (-1)**nv*c0*Pmv elseif ( x>=-0.35d0 ) then ! DLMF 14.3.4, 15.2.1 Pmv = 1.0_wp r = 1.0_wp do k = 1 , 100 r = 0.5_wp*r*(-v+m+k-1.0_wp)*(v+m+k)/(k*(m+k))*(1.0_wp-x) Pmv = Pmv + r if ( k>12 .and. abs(r/Pmv)<eps ) exit enddo Pmv = (-1)**m*c0*Pmv else ! DLMF 14.3.5, 15.8.10 vs = sin(v*pi)/pi pv0 = 0.0_wp if ( m/=0 ) then qr = sqrt((1.0_wp-x)/(1.0_wp+x)) r2 = 1.0_wp do j = 1 , m r2 = r2*qr*j enddo s0 = 1.0_wp r1 = 1.0_wp do k = 1 , m - 1 r1 = 0.5_wp*r1*(-v+k-1)*(v+k)/(k*(k-m))*(1.0_wp+x) s0 = s0 + r1 enddo pv0 = -vs*r2/m*s0 endif call psi_spec(v,psv) pa = 2.0_wp*(psv+el) + pi/tan(pi*v) + 1.0_wp/v s1 = 0.0_wp do j = 1 , m s1 = s1 + (j*j+v*v)/(j*(j*j-v*v)) enddo Pmv = pa + s1 - 1.0_wp/(m-v) + log(0.5_wp*(1.0_wp+x)) r = 1.0_wp do k = 1 , 100 r = 0.5_wp*r*(-v+m+k-1.0_wp)*(v+m+k)/(k*(k+m))*(1.0_wp+x) s = 0.0_wp do j = 1 , m s = s + ((k+j)**2+v*v)/((k+j)*((k+j)**2-v*v)) enddo s2 = 0.0_wp do j = 1 , k s2 = s2 + 1.0_wp/(j*(j*j-v*v)) enddo pss = pa + s + 2.0_wp*v*v*s2 - 1.0_wp/(m+k-v) & & + log(0.5_wp*(1.0_wp+x)) r2 = pss*r Pmv = Pmv + r2 if ( abs(r2/Pmv)<eps ) exit enddo Pmv = pv0 + Pmv*vs*c0 endif end subroutine lpmv(v,m,x,Pmv) ! ! ======================================================= ! Purpose: Compute the associated Legendre function ! Pmv(x) with an integer order and an arbitrary ! degree v, using recursion for large degrees ! Input : x --- Argument of Pm(x) ( -1 ≤ x ≤ 1 ) ! m --- Order of Pmv(x) ! v --- Degree of Pmv(x) ! Output: PMV --- Pmv(x) ! Routine called: LPMV0 ! ======================================================= ! implicit none real(wp) g1 , g2 , p0 , p1 , Pmv , v , v0 , & & vx , x integer j , m , mx , neg_m , nv if ( x==-1.0_wp .and. v/=int(v) ) then if ( m==0 ) Pmv = -dinf() if ( m/=0 ) Pmv = dinf() return endif vx = v mx = m ! DLMF 14.9.5 if ( v<0 ) vx = -vx - 1 neg_m = 0 if ( m<0 ) then if ( (vx+m+1)>0d0 .or. vx/=int(vx) ) then neg_m = 1 mx = -m else ! We don't handle cases where DLMF 14.9.3 doesn't help Pmv = dnan() return endif endif nv = int(vx) v0 = vx - nv if ( nv>2 .and. nv>mx ) then ! Up-recursion on degree, AMS 8.5.3 / DLMF 14.10.3 call lpmv0(v0+mx,mx,x,p0) call lpmv0(v0+mx+1,mx,x,p1) Pmv = p1 do j = mx + 2 , nv Pmv = ((2*(v0+j)-1)*x*p1-(v0+j-1+mx)*p0)/(v0+j-mx) p0 = p1 p1 = Pmv enddo else call lpmv0(vx,mx,x,Pmv) endif if ( neg_m/=0 .and. abs(Pmv)<1.0e+300_wp ) then ! DLMF 14.9.3 call gamma2(vx-mx+1,g1) call gamma2(vx+mx+1,g2) Pmv = Pmv*g1/g2*(-1)**mx endif end subroutine cgama(x,y,Kf,Gr,Gi) ! ! ========================================================= ! Purpose: Compute the gamma function Г(z) or ln[Г(z)] ! for a complex argument ! Input : x --- Real part of z ! y --- Imaginary part of z ! KF --- Function code ! KF=0 for ln[Г(z)] ! KF=1 for Г(z) ! Output: GR --- Real part of ln[Г(z)] or Г(z) ! GI --- Imaginary part of ln[Г(z)] or Г(z) ! ======================================================== ! implicit none real(wp) a , g0 , Gi , gi1 , Gr , gr1 , si , sr , t ,& & th , th1 , th2 , x , x0 , x1 , y , y1 , z1 , z2 integer j , k , Kf , na dimension a(10) data a/8.333333333333333d-02 , -2.777777777777778d-03 , & & 7.936507936507937d-04 , -5.952380952380952d-04 , & & 8.417508417508418d-04 , -1.917526917526918d-03 , & & 6.410256410256410d-03 , -2.955065359477124d-02 , & & 1.796443723688307d-01 , -1.39243221690590d+00/ if ( y==0.0_wp .and. x==int(x) .and. x<=0.0_wp ) then Gr = 1.0e+300_wp Gi = 0.0_wp return elseif ( x<0.0_wp ) then x1 = x y1 = y x = -x y = -y else y1 = 0.0_wp x1 = x endif x0 = x na = 0 if ( x<=7.0 ) then na = int(7-x) x0 = x + na endif z1 = sqrt(x0*x0+y*y) th = atan(y/x0) Gr = (x0-0.5_wp)*log(z1) - th*y - x0 + 0.5_wp*log(2.0_wp*pi) Gi = th*(x0-0.5_wp) + y*log(z1) - y do k = 1 , 10 t = z1**(1-2*k) Gr = Gr + a(k)*t*cos((2.0_wp*k-1.0_wp)*th) Gi = Gi - a(k)*t*sin((2.0_wp*k-1.0_wp)*th) enddo if ( x<=7.0 ) then gr1 = 0.0_wp gi1 = 0.0_wp do j = 0 , na - 1 gr1 = gr1 + .5d0*log((x+j)**2+y*y) gi1 = gi1 + atan(y/(x+j)) enddo Gr = Gr - gr1 Gi = Gi - gi1 endif if ( x1<0.0_wp ) then z1 = sqrt(x*x+y*y) th1 = atan(y/x) sr = -sin(pi*x)*cosh(pi*y) si = -cos(pi*x)*sinh(pi*y) z2 = sqrt(sr*sr+si*si) th2 = atan(si/sr) if ( sr<0.0_wp ) th2 = pi + th2 Gr = log(pi/(z1*z2)) - Gr Gi = -th1 - th2 - Gi x = x1 y = y1 endif if ( Kf==1 ) then g0 = exp(Gr) Gr = g0*cos(Gi) Gi = g0*sin(Gi) endif end subroutine aswfb(m,n,c,x,Kd,Cv,S1f,S1d) ! ! =========================================================== ! Purpose: Compute the prolate and oblate spheroidal angular ! functions of the first kind and their derivatives ! Input : m --- Mode parameter, m = 0,1,2,... ! n --- Mode parameter, n = m,m+1,... ! c --- Spheroidal parameter ! x --- Argument of angular function, |x| < 1.0 ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! cv --- Characteristic value ! Output: S1F --- Angular function of the first kind ! S1D --- Derivative of the angular function of ! the first kind ! Routines called: ! (1) SDMN for computing expansion coefficients dk ! (2) LPMNS for computing associated Legendre function ! of the first kind Pmn(x) ! =========================================================== ! implicit none real(wp) c , Cv , df , eps , pd , pm , S1d , S1f , su1 , & & sw , x integer ip , k , Kd , m , mk , n , nm , nm2 dimension df(200) , pm(0:251) , pd(0:251) eps = 1.0d-14 ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 nm = 25 + int((n-m)/2+c) nm2 = 2*nm + m call sdmn(m,n,c,Cv,Kd,df) call lpmns(m,nm2,x,pm,pd) sw = 0.0_wp su1 = 0.0_wp do k = 1 , nm mk = m + 2*(k-1) + ip su1 = su1 + df(k)*pm(mk) if ( abs(sw-su1)<abs(su1)*eps ) exit sw = su1 enddo S1f = (-1)**m*su1 su1 = 0.0_wp do k = 1 , nm mk = m + 2*(k-1) + ip su1 = su1 + df(k)*pd(mk) if ( abs(sw-su1)<abs(su1)*eps ) exit sw = su1 enddo S1d = (-1)**m*su1 end subroutine chgus(a,b,x,Hu,Id) ! ! ====================================================== ! Purpose: Compute confluent hypergeometric function ! U(a,b,x) for small argument x ! Input : a --- Parameter ! b --- Parameter ( b <> 0,-1,-2,...) ! x --- Argument ! Output: HU --- U(a,b,x) ! ID --- Estimated number of significant digits ! Routine called: GAMMA2 for computing gamma function ! ====================================================== ! ! DLMF 13.2.42 with prefactors rewritten according to ! DLMF 5.5.3, M(a, b, x) with DLMF 13.2.2 ! implicit none real(wp) a , b , d1 , d2 , ga , gab , gb , gb2 , h0 , & & hmax , hmin , Hu , hu0 , hua , r1 , r2 , x ,& & xg1 , xg2 integer Id , j Id = -100 call gamma2(a,ga) call gamma2(b,gb) xg1 = 1.0_wp + a - b call gamma2(xg1,gab) xg2 = 2.0_wp - b call gamma2(xg2,gb2) hu0 = pi/sin(pi*b) r1 = hu0/(gab*gb) r2 = hu0*x**(1.0_wp-b)/(ga*gb2) Hu = r1 - r2 hmax = 0.0_wp hmin = 1.0e+300_wp h0 = 0.0_wp do j = 1 , 150 r1 = r1*(a+j-1.0_wp)/(j*(b+j-1.0_wp))*x r2 = r2*(a-b+j)/(j*(1.0_wp-b+j))*x Hu = Hu + r1 - r2 hua = abs(Hu) if ( hua>hmax ) hmax = hua if ( hua<hmin ) hmin = hua if ( abs(Hu-h0)<abs(Hu)*1.0d-15 ) exit h0 = Hu enddo d1 = log10(hmax) d2 = 0.0_wp if ( hmin/=0.0 ) d2 = log10(hmin) Id = 15 - abs(d1-d2) end subroutine itth0(x,Tth) ! ! =========================================================== ! Purpose: Evaluate the integral H0(t)/t with respect to t ! from x to infinity ! Input : x --- Lower limit ( x ≥ 0 ) ! Output: TTH --- Integration of H0(t)/t from x to infinity ! =========================================================== ! implicit none real(wp) f0 , g0 , r , s , t , Tth , tty , x , xt integer k s = 1.0_wp r = 1.0_wp if ( x<24.5d0 ) then do k = 1 , 60 r = -r*x*x*(2.0*k-1.0_wp)/(2.0*k+1.0_wp)**3 s = s + r if ( abs(r)<abs(s)*1.0d-12 ) exit enddo Tth = pi/2.0_wp - 2.0_wp/pi*x*s else do k = 1 , 10 r = -r*(2.0*k-1.0_wp)**3/((2.0*k+1.0_wp)*x*x) s = s + r if ( abs(r)<abs(s)*1.0d-12 ) exit enddo Tth = 2.0_wp/(pi*x)*s t = 8.0_wp/x xt = x + .25d0*pi f0 = (((((.18118d-2*t-.91909d-2)*t+.017033d0)*t-.9394d-3) & & *t-.051445d0)*t-.11d-5)*t + .7978846d0 g0 = (((((-.23731d-2*t+.59842d-2)*t+.24437d-2)*t-.0233178d0) & & *t+.595d-4)*t+.1620695d0)*t tty = (f0*sin(xt)-g0*cos(xt))/(sqrt(x)*x) Tth = Tth + tty endif end subroutine lgama(Kf,x,Gl) ! ! ================================================== ! Purpose: Compute gamma function Г(x) or ln[Г(x)] ! Input: x --- Argument of Г(x) ( x > 0 ) ! KF --- Function code ! KF=1 for Г(x); KF=0 for ln[Г(x)] ! Output: GL --- Г(x) or ln[Г(x)] ! ================================================== ! implicit none real(wp) a , Gl , gl0 , x , x0 , x2 , xp integer k , Kf , n dimension a(10) data a/8.333333333333333d-02 , -2.777777777777778d-03 , & & 7.936507936507937d-04 , -5.952380952380952d-04 , & & 8.417508417508418d-04 , -1.917526917526918d-03 , & & 6.410256410256410d-03 , -2.955065359477124d-02 , & & 1.796443723688307d-01 , -1.39243221690590d+00/ x0 = x n = 0 if ( x==1.0 .or. x==2.0 ) then Gl = 0.0_wp goto 100 elseif ( x<=7.0 ) then n = int(7-x) x0 = x + n endif x2 = 1.0_wp/(x0*x0) xp = 6.283185307179586477d0 gl0 = a(10) do k = 9 , 1 , -1 gl0 = gl0*x2 + a(k) enddo Gl = gl0/x0 + 0.5_wp*log(xp) + (x0-0.5_wp)*log(x0) - x0 if ( x<=7.0 ) then do k = 1 , n Gl = Gl - log(x0-1.0_wp) x0 = x0 - 1.0_wp enddo endif 100 if ( Kf==1 ) Gl = exp(Gl) end subroutine lqna(n,x,Qn,Qd) ! ! ===================================================== ! Purpose: Compute Legendre functions Qn(x) and Qn'(x) ! Input : x --- Argument of Qn(x) ( -1 ≤ x ≤ 1 ) ! n --- Degree of Qn(x) ( n = 0,1,2,… ) ! Output: QN(n) --- Qn(x) ! QD(n) --- Qn'(x) ! ( 1.0D+300 stands for infinity ) ! ===================================================== ! implicit none integer k , n real(wp) q0 , q1 , Qd , qf , Qn , x dimension Qn(0:n) , Qd(0:n) if ( abs(x)==1.0_wp ) then do k = 0 , n Qn(k) = 1.0e+300_wp Qd(k) = -1.0e+300_wp enddo elseif ( abs(x)<1.0_wp ) then q0 = 0.5_wp*log((1.0_wp+x)/(1.0_wp-x)) q1 = x*q0 - 1.0_wp Qn(0) = q0 Qn(1) = q1 Qd(0) = 1.0_wp/(1.0_wp-x*x) Qd(1) = Qn(0) + x*Qd(0) do k = 2 , n qf = ((2*k-1)*x*q1-(k-1)*q0)/k Qn(k) = qf Qd(k) = (Qn(k-1)-x*qf)*k/(1.0_wp-x*x) q0 = q1 q1 = qf enddo endif end subroutine dvla(Va,x,Pd) ! ! ==================================================== ! Purpose: Compute parabolic cylinder functions Dv(x) ! for large argument ! Input: x --- Argument ! va --- Order ! Output: PD --- Dv(x) ! Routines called: ! (1) VVLA for computing Vv(x) for large |x| ! (2) GAMMA2 for computing Г(x) ! ==================================================== ! implicit none real(wp) a0 , ep , eps , gl , Pd , r , Va , vl , x , & & x1 integer k eps = 1.0d-12 ep = exp(-.25*x*x) a0 = abs(x)**Va*ep r = 1.0_wp Pd = 1.0_wp do k = 1 , 16 r = -0.5_wp*r*(2.0*k-Va-1.0)*(2.0*k-Va-2.0)/(k*x*x) Pd = Pd + r if ( abs(r/Pd)<eps ) exit enddo Pd = a0*Pd if ( x<0.0_wp ) then x1 = -x call vvla(Va,x1,vl) call gamma2(-Va,gl) Pd = pi*vl/gl + cos(pi*Va)*Pd endif end subroutine ik01a(x,Bi0,Di0,Bi1,Di1,Bk0,Dk0,Bk1,Dk1) ! ! ========================================================= ! Purpose: Compute modified Bessel functions I0(x), I1(1), ! K0(x) and K1(x), and their derivatives ! Input : x --- Argument ( x ≥ 0 ) ! Output: BI0 --- I0(x) ! DI0 --- I0'(x) ! BI1 --- I1(x) ! DI1 --- I1'(x) ! BK0 --- K0(x) ! DK0 --- K0'(x) ! BK1 --- K1(x) ! DK1 --- K1'(x) ! ========================================================= ! implicit none real(wp) a , a1 , b , Bi0 , Bi1 , Bk0 , Bk1 , ca , cb , & & ct , Di0 , Di1 , Dk0 , Dk1 , el , r , w0 , & & ww , x real(wp) x2 , xr , xr2 integer k , k0 dimension a(12) , b(12) , a1(8) el = 0.5772156649015329d0 x2 = x*x if ( x==0.0_wp ) then Bi0 = 1.0_wp Bi1 = 0.0_wp Bk0 = 1.0e+300_wp Bk1 = 1.0e+300_wp Di0 = 0.0_wp Di1 = 0.5_wp Dk0 = -1.0e+300_wp Dk1 = -1.0e+300_wp return elseif ( x<=18.0d0 ) then Bi0 = 1.0_wp r = 1.0_wp do k = 1 , 50 r = 0.25d0*r*x2/(k*k) Bi0 = Bi0 + r if ( abs(r/Bi0)<1.0d-15 ) exit enddo Bi1 = 1.0_wp r = 1.0_wp do k = 1 , 50 r = 0.25d0*r*x2/(k*(k+1)) Bi1 = Bi1 + r if ( abs(r/Bi1)<1.0d-15 ) exit enddo Bi1 = 0.5_wp*x*Bi1 else data a/0.125d0 , 7.03125d-2 , 7.32421875d-2 , & & 1.1215209960938d-1 , 2.2710800170898d-1 , & & 5.7250142097473d-1 , 1.7277275025845d0 , & & 6.0740420012735d0 , 2.4380529699556d01 , & & 1.1001714026925d02 , 5.5133589612202d02 , & & 3.0380905109224d03/ data b/ - 0.375d0 , -1.171875d-1 , -1.025390625d-1 , & & -1.4419555664063d-1 , -2.7757644653320d-1 , & & -6.7659258842468d-1 , -1.9935317337513d0 , & & -6.8839142681099d0 , -2.7248827311269d01 , & & -1.2159789187654d02 , -6.0384407670507d02 , & & -3.3022722944809d03/ k0 = 12 if ( x>=35.0 ) k0 = 9 if ( x>=50.0 ) k0 = 7 ca = exp(x)/sqrt(2.0_wp*pi*x) Bi0 = 1.0_wp xr = 1.0_wp/x do k = 1 , k0 Bi0 = Bi0 + a(k)*xr**k enddo Bi0 = ca*Bi0 Bi1 = 1.0_wp do k = 1 , k0 Bi1 = Bi1 + b(k)*xr**k enddo Bi1 = ca*Bi1 endif ww = 0.0_wp if ( x<=9.0_wp ) then ct = -(log(x/2.0_wp)+el) Bk0 = 0.0_wp w0 = 0.0_wp r = 1.0_wp do k = 1 , 50 w0 = w0 + 1.0_wp/k r = 0.25d0*r/(k*k)*x2 Bk0 = Bk0 + r*(w0+ct) if ( abs((Bk0-ww)/Bk0)<1.0d-15 ) exit ww = Bk0 enddo Bk0 = Bk0 + ct else data a1/0.125d0 , 0.2109375d0 , 1.0986328125d0 , & & 1.1775970458984d01 , 2.1461706161499d02 , & & 5.9511522710323d03 , 2.3347645606175d05 , & & 1.2312234987631d07/ cb = 0.5_wp/x xr2 = 1.0_wp/x2 Bk0 = 1.0_wp do k = 1 , 8 Bk0 = Bk0 + a1(k)*xr2**k enddo Bk0 = cb*Bk0/Bi0 endif Bk1 = (1.0_wp/x-Bi1*Bk0)/Bi0 Di0 = Bi1 Di1 = Bi0 - Bi1/x Dk0 = -Bk1 Dk1 = -Bk0 - Bk1/x end subroutine cpbdn(n,z,Cpb,Cpd) ! ! ================================================== ! Purpose: Compute the parabolic cylinder functions ! Dn(z) and Dn'(z) for a complex argument ! Input: z --- Complex argument of Dn(z) ! n --- Order of Dn(z) ( n=0,±1,±2,… ) ! Output: CPB(|n|) --- Dn(z) ! CPD(|n|) --- Dn'(z) ! Routines called: ! (1) CPDSA for computing Dn(z) for a small |z| ! (2) CPDLA for computing Dn(z) for a large |z| ! ================================================== ! implicit none real(wp) a0 , x complex(wp) c0 , ca0 , cf , cf0 , cf1 , cfa , cfb , Cpb , Cpd , & & cs0 , z , z1 integer k , m , n , n0 , n1 , nm1 dimension Cpb(0:*) , Cpd(0:*) x = real(z,wp) a0 = abs(z) c0 = (0.0_wp,0.0_wp) ca0 = exp(-0.25d0*z*z) n0 = 0 if ( n>=0 ) then cf0 = ca0 cf1 = z*ca0 Cpb(0) = cf0 Cpb(1) = cf1 do k = 2 , n cf = z*cf1 - (k-1.0_wp)*cf0 Cpb(k) = cf cf0 = cf1 cf1 = cf enddo else n0 = -n if ( x<=0.0 .or. abs(z)==0.0 ) then cf0 = ca0 Cpb(0) = cf0 z1 = -z if ( a0<=7.0 ) then call cpdsa(-1,z1,cf1) else call cpdla(-1,z1,cf1) endif cf1 = sqrt(2.0_wp*pi)/ca0 - cf1 Cpb(1) = cf1 do k = 2 , n0 cf = (-z*cf1+cf0)/(k-1.0_wp) Cpb(k) = cf cf0 = cf1 cf1 = cf enddo elseif ( a0<=3.0 ) then call cpdsa(-n0,z,cfa) Cpb(n0) = cfa n1 = n0 + 1 call cpdsa(-n1,z,cfb) Cpb(n1) = cfb nm1 = n0 - 1 do k = nm1 , 0 , -1 cf = z*cfa + (k+1.0_wp)*cfb Cpb(k) = cf cfb = cfa cfa = cf enddo else m = 100 + abs(n) cfa = c0 cfb = (1.0d-30,0.0_wp) do k = m , 0 , -1 cf = z*cfb + (k+1.0_wp)*cfa if ( k<=n0 ) Cpb(k) = cf cfa = cfb cfb = cf enddo cs0 = ca0/cf do k = 0 , n0 Cpb(k) = cs0*Cpb(k) enddo endif endif Cpd(0) = -0.5_wp*z*Cpb(0) if ( n>=0 ) then do k = 1 , n Cpd(k) = -0.5_wp*z*Cpb(k) + k*Cpb(k-1) enddo else do k = 1 , n0 Cpd(k) = 0.5_wp*z*Cpb(k) - Cpb(k-1) enddo endif end subroutine ik01b(x,Bi0,Di0,Bi1,Di1,Bk0,Dk0,Bk1,Dk1) ! ! ========================================================= ! Purpose: Compute modified Bessel functions I0(x), I1(1), ! K0(x) and K1(x), and their derivatives ! Input : x --- Argument ( x ≥ 0 ) ! Output: BI0 --- I0(x) ! DI0 --- I0'(x) ! BI1 --- I1(x) ! DI1 --- I1'(x) ! BK0 --- K0(x) ! DK0 --- K0'(x) ! BK1 --- K1(x) ! DK1 --- K1'(x) ! ========================================================= ! implicit none real(wp) Bi0 , Bi1 , Bk0 , Bk1 , Di0 , Di1 , Dk0 , Dk1 , & & t , t2 , x if ( x==0.0_wp ) then Bi0 = 1.0_wp Bi1 = 0.0_wp Bk0 = 1.0e+300_wp Bk1 = 1.0e+300_wp Di0 = 0.0_wp Di1 = 0.5_wp Dk0 = -1.0e+300_wp Dk1 = -1.0e+300_wp return elseif ( x<=3.75d0 ) then t = x/3.75d0 t2 = t*t Bi0 = (((((.0045813d0*t2+.0360768d0)*t2+.2659732d0)*t2+ & & 1.2067492d0)*t2+3.0899424d0)*t2+3.5156229d0)*t2 + 1.0_wp Bi1 = x*((((((.00032411d0*t2+.00301532d0)*t2+.02658733d0)*t2+ & & .15084934d0)*t2+.51498869d0)*t2+.87890594d0)*t2+.5d0) else t = 3.75d0/x Bi0 = ((((((((.00392377d0*t-.01647633d0)*t+.02635537d0)*t- & & .02057706d0)*t+.916281d-2)*t-.157565d-2)*t+.225319d-2) & & *t+.01328592d0)*t+.39894228d0)*exp(x)/sqrt(x) Bi1 = ((((((((-.420059d-2*t+.01787654d0)*t-.02895312d0)*t+ & & .02282967d0)*t-.01031555d0)*t+.163801d-2)*t-.00362018d0) & & *t-.03988024d0)*t+.39894228d0)*exp(x)/sqrt(x) endif if ( x<=2.0_wp ) then t = x/2.0_wp t2 = t*t Bk0 = (((((.0000074d0*t2+.0001075d0)*t2+.00262698d0)*t2+ & & .0348859d0)*t2+.23069756d0)*t2+.4227842d0) & & *t2 - .57721566d0 - Bi0*log(t) Bk1 = ((((((-.00004686d0*t2-.00110404d0)*t2-.01919402d0)*t2- & & .18156897d0)*t2-.67278579d0)*t2+.15443144d0)*t2+1.0_wp) & & /x + Bi1*log(t) else t = 2.0_wp/x t2 = t*t Bk0 = ((((((.00053208d0*t-.0025154d0)*t+.00587872d0)*t- & & .01062446d0)*t+.02189568d0)*t-.07832358d0) & & *t+1.25331414d0)*exp(-x)/sqrt(x) Bk1 = ((((((-.00068245d0*t+.00325614d0)*t-.00780353d0)*t+ & & .01504268d0)*t-.0365562d0)*t+.23498619d0)*t+1.25331414d0)& & *exp(-x)/sqrt(x) endif Di0 = Bi1 Di1 = Bi0 - Bi1/x Dk0 = -Bk1 Dk1 = -Bk0 - Bk1/x end subroutine beta(p,q,Bt) ! ! ========================================== ! Purpose: Compute the beta function B(p,q) ! Input : p --- Parameter ( p > 0 ) ! q --- Parameter ( q > 0 ) ! Output: BT --- B(p,q) ! Routine called: GAMMA2 for computing Г(x) ! ========================================== ! implicit none real(wp) Bt , gp , gpq , gq , p , ppq , q call gamma2(p,gp) call gamma2(q,gq) ppq = p + q call gamma2(ppq,gpq) Bt = gp*gq/gpq end subroutine lpn(n,x,Pn,Pd) ! ! =============================================== ! Purpose: Compute Legendre polynomials Pn(x) ! and their derivatives Pn'(x) ! Input : x --- Argument of Pn(x) ! n --- Degree of Pn(x) ( n = 0,1,...) ! Output: PN(n) --- Pn(x) ! PD(n) --- Pn'(x) ! =============================================== ! implicit none integer k , n real(wp) p0 , p1 , Pd , pf , Pn , x dimension Pn(0:n) , Pd(0:n) Pn(0) = 1.0_wp Pn(1) = x Pd(0) = 0.0_wp Pd(1) = 1.0_wp p0 = 1.0_wp p1 = x do k = 2 , n pf = (2.0_wp*k-1.0_wp)/k*x*p1 - (k-1.0_wp)/k*p0 Pn(k) = pf if ( abs(x)==1.0_wp ) then Pd(k) = 0.5_wp*x**(k+1)*k*(k+1.0_wp) else Pd(k) = k*(p1-x*pf)/(1.0_wp-x*x) endif p0 = p1 p1 = pf enddo end subroutine fcoef(Kd,m,q,a,Fc) ! ! ===================================================== ! Purpose: Compute expansion coefficients for Mathieu ! functions and modified Mathieu functions ! Input : m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ! KD --- Case code ! KD=1 for cem(x,q) ( m = 0,2,4,...) ! KD=2 for cem(x,q) ( m = 1,3,5,...) ! KD=3 for sem(x,q) ( m = 1,3,5,...) ! KD=4 for sem(x,q) ( m = 2,4,6,...) ! A --- Characteristic value of Mathieu ! functions for given m and q ! Output: FC(k) --- Expansion coefficients of Mathieu ! functions ( k= 1,2,...,KM ) ! FC(1),FC(2),FC(3),... correspond to ! A0,A2,A4,... for KD=1 case, A1,A3, ! A5,... for KD=2 case, B1,B3,B5,... ! for KD=3 case and B2,B4,B6,... for ! KD=4 case ! ===================================================== ! implicit none real(wp) a , f , f1 , f2 , f3 , Fc , fnan , q , & & qm , s , s0 , sp , ss , u , v integer i , j , jm , k , kb , Kd , km , m dimension Fc(251) do i = 1 , 251 Fc(i) = 0.0_wp enddo if ( abs(q)<=1.0d-7 ) then ! Expansion up to order Q^1 (Abramowitz & Stegun 20.2.27-28) if ( Kd==1 ) then jm = m/2 + 1 elseif ( Kd==2 .or. Kd==3 ) then jm = (m-1)/2 + 1 elseif ( Kd==4 ) then jm = m/2 endif ! Check for overflow if ( jm+1>251 ) then fnan = dnan() do i = 1 , 251 Fc(i) = fnan enddo return endif ! Proceed using the simplest expansion if ( Kd==1 .or. Kd==2 ) then if ( m==0 ) then Fc(1) = 1/sqrt(2.0_wp) Fc(2) = -q/2.0_wp/sqrt(2.0_wp) elseif ( m==1 ) then Fc(1) = 1.0_wp Fc(2) = -q/8.0_wp elseif ( m==2 ) then Fc(1) = q/4.0_wp Fc(2) = 1.0_wp Fc(3) = -q/12.0d0 else Fc(jm) = 1.0_wp Fc(jm+1) = -q/(4.0_wp*(m+1)) Fc(jm-1) = q/(4.0_wp*(m-1)) endif elseif ( Kd==3 .or. Kd==4 ) then if ( m==1 ) then Fc(1) = 1.0_wp Fc(2) = -q/8.0_wp elseif ( m==2 ) then Fc(1) = 1.0_wp Fc(2) = -q/12.0d0 else Fc(jm) = 1.0_wp Fc(jm+1) = -q/(4.0_wp*(m+1)) Fc(jm-1) = q/(4.0_wp*(m-1)) endif endif return elseif ( q<=1.0_wp ) then qm = 7.5 + 56.1*sqrt(q) - 134.7*q + 90.7*sqrt(q)*q else qm = 17.0 + 3.1*sqrt(q) - .126*q + .0037*sqrt(q)*q endif km = int(qm+0.5*m) if ( km>251 ) then ! Overflow, generate NaNs fnan = dnan() do i = 1 , 251 Fc(i) = fnan enddo return endif kb = 0 s = 0.0_wp f = 1.0d-100 u = 0.0_wp Fc(km) = 0.0_wp f2 = 0.0_wp if ( Kd==1 ) then do k = km , 3 , -1 v = u u = f f = (a-4.0_wp*k*k)*u/q - v if ( abs(f)<abs(Fc(k+1)) ) then kb = k Fc(1) = 1.0d-100 sp = 0.0_wp f3 = Fc(k+1) Fc(2) = a/q*Fc(1) Fc(3) = (a-4.0_wp)*Fc(2)/q - 2.0_wp*Fc(1) u = Fc(2) f1 = Fc(3) do i = 3 , kb v = u u = f1 f1 = (a-4.0_wp*(i-1.0_wp)**2)*u/q - v Fc(i+1) = f1 if ( i==kb ) f2 = f1 if ( i/=kb ) sp = sp + f1*f1 enddo sp = sp + 2.0_wp*Fc(1)**2 + Fc(2)**2 + Fc(3)**2 ss = s + sp*(f3/f2)**2 s0 = sqrt(1.0_wp/ss) do j = 1 , km if ( j<=kb+1 ) then Fc(j) = s0*Fc(j)*f3/f2 else Fc(j) = s0*Fc(j) endif enddo goto 200 else Fc(k) = f s = s + f*f endif enddo Fc(2) = q*Fc(3)/(a-4.0_wp-2.0_wp*q*q/a) Fc(1) = q/a*Fc(2) s = s + 2.0_wp*Fc(1)**2 + Fc(2)**2 s0 = sqrt(1.0_wp/s) do k = 1 , km Fc(k) = s0*Fc(k) enddo elseif ( Kd==2 .or. Kd==3 ) then do k = km , 3 , -1 v = u u = f f = (a-(2.0_wp*k-1)**2)*u/q - v if ( abs(f)>=abs(Fc(k)) ) then Fc(k-1) = f s = s + f*f else kb = k f3 = Fc(k) goto 50 endif enddo Fc(1) = q/(a-1.0_wp-(-1)**Kd*q)*Fc(2) s = s + Fc(1)*Fc(1) s0 = sqrt(1.0_wp/s) do k = 1 , km Fc(k) = s0*Fc(k) enddo goto 200 50 Fc(1) = 1.0d-100 Fc(2) = (a-1.0_wp-(-1)**Kd*q)/q*Fc(1) sp = 0.0_wp u = Fc(1) f1 = Fc(2) do i = 2 , kb - 1 v = u u = f1 f1 = (a-(2.0_wp*i-1.0_wp)**2)*u/q - v if ( i/=kb-1 ) then Fc(i+1) = f1 sp = sp + f1*f1 else f2 = f1 endif enddo sp = sp + Fc(1)**2 + Fc(2)**2 ss = s + sp*(f3/f2)**2 s0 = 1.0_wp/sqrt(ss) do j = 1 , km if ( j<kb ) Fc(j) = s0*Fc(j)*f3/f2 if ( j>=kb ) Fc(j) = s0*Fc(j) enddo elseif ( Kd==4 ) then do k = km , 3 , -1 v = u u = f f = (a-4.0_wp*k*k)*u/q - v if ( abs(f)>=abs(Fc(k)) ) then Fc(k-1) = f s = s + f*f else kb = k f3 = Fc(k) goto 100 endif enddo Fc(1) = q/(a-4.0_wp)*Fc(2) s = s + Fc(1)*Fc(1) s0 = sqrt(1.0_wp/s) do k = 1 , km Fc(k) = s0*Fc(k) enddo goto 200 100 Fc(1) = 1.0d-100 Fc(2) = (a-4.0_wp)/q*Fc(1) sp = 0.0_wp u = Fc(1) f1 = Fc(2) do i = 2 , kb - 1 v = u u = f1 f1 = (a-4.0_wp*i*i)*u/q - v if ( i/=kb-1 ) then Fc(i+1) = f1 sp = sp + f1*f1 else f2 = f1 endif enddo sp = sp + Fc(1)**2 + Fc(2)**2 ss = s + sp*(f3/f2)**2 s0 = 1.0_wp/sqrt(ss) do j = 1 , km if ( j<kb ) Fc(j) = s0*Fc(j)*f3/f2 if ( j>=kb ) Fc(j) = s0*Fc(j) enddo endif 200 if ( Fc(1)<0.0_wp ) then do j = 1 , km Fc(j) = -Fc(j) enddo endif end subroutine sphi(n,x,Nm,Si,Di) ! ! ======================================================== ! Purpose: Compute modified spherical Bessel functions ! of the first kind, in(x) and in'(x) ! Input : x --- Argument of in(x) ! n --- Order of in(x) ( n = 0,1,2,... ) ! Output: SI(n) --- in(x) ! DI(n) --- in'(x) ! NM --- Highest order computed ! Routines called: ! MSTA1 and MSTA2 for computing the starting ! point for backward recurrence ! ======================================================== ! implicit none real(wp) cs , Di , f , f0 , f1 , Si , si0 , x integer k , m , n , Nm dimension Si(0:n) , Di(0:n) Nm = n if ( abs(x)<1.0d-100 ) then do k = 0 , n Si(k) = 0.0_wp Di(k) = 0.0_wp enddo Si(0) = 1.0_wp Di(1) = 0.333333333333333d0 return endif Si(0) = sinh(x)/x Si(1) = -(sinh(x)/x-cosh(x))/x si0 = Si(0) if ( n>=2 ) then m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f = 0.0_wp f0 = 0.0_wp f1 = 1.0_wp - 100 do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f1/x + f0 if ( k<=Nm ) Si(k) = f f0 = f1 f1 = f enddo cs = si0/f do k = 0 , Nm Si(k) = cs*Si(k) enddo endif Di(0) = Si(1) do k = 1 , Nm Di(k) = Si(k-1) - (k+1.0_wp)/x*Si(k) enddo end subroutine pbwa(a,x,W1f,W1d,W2f,W2d) ! ! ====================================================== ! Purpose: Compute parabolic cylinder functions W(a,±x) ! and their derivatives ! Input : a --- Parameter ( 0 ≤ |a| ≤ 5 ) ! x --- Argument of W(a,±x) ( 0 ≤ |x| ≤ 5 ) ! Output : W1F --- W(a,x) ! W1D --- W'(a,x) ! W2F --- W(a,-x) ! W2D --- W'(a,-x) ! Routine called: ! CGAMA for computing complex gamma function ! ====================================================== ! implicit none real(wp) a , d , d1 , d2 , dl , eps , f1 , f2 , g1 , g2 , & & h , h0 , h1 , hl , p0 , r , r1 , ugi , ugr , vgi real(wp) vgr , W1d , W1f , W2d , W2f , x , x1 , x2 , y1 , & & y1d , y1f , y2d , y2f integer k , l1 , l2 , m dimension h(100) , d(80) eps = 1.0d-15 p0 = 0.59460355750136d0 if ( a==0.0_wp ) then g1 = 3.625609908222d0 g2 = 1.225416702465d0 else x1 = 0.25d0 y1 = 0.5_wp*a call cgama(x1,y1,1,ugr,ugi) g1 = sqrt(ugr*ugr+ugi*ugi) x2 = 0.75d0 call cgama(x2,y1,1,vgr,vgi) g2 = sqrt(vgr*vgr+vgi*vgi) endif f1 = sqrt(g1/g2) f2 = sqrt(2.0_wp*g2/g1) h0 = 1.0_wp h1 = a h(1) = a do l1 = 4 , 200 , 2 m = l1/2 hl = a*h1 - 0.25d0*(l1-2.0_wp)*(l1-3.0_wp)*h0 h(m) = hl h0 = h1 h1 = hl enddo y1f = 1.0_wp r = 1.0_wp do k = 1 , 100 r = 0.5_wp*r*x*x/(k*(2.0_wp*k-1.0_wp)) r1 = h(k)*r y1f = y1f + r1 if ( abs(r1)<=eps*abs(y1f) .and. k>30 ) exit enddo y1d = a r = 1.0_wp do k = 1 , 99 r = 0.5_wp*r*x*x/(k*(2.0_wp*k+1.0_wp)) r1 = h(k+1)*r y1d = y1d + r1 if ( abs(r1)<=eps*abs(y1d) .and. k>30 ) exit enddo y1d = x*y1d d1 = 1.0_wp d2 = a d(1) = 1.0_wp d(2) = a do l2 = 5 , 160 , 2 m = (l2+1)/2 dl = a*d2 - 0.25d0*(l2-2.0_wp)*(l2-3.0_wp)*d1 d(m) = dl d1 = d2 d2 = dl enddo y2f = 1.0_wp r = 1.0_wp do k = 1 , 79 r = 0.5_wp*r*x*x/(k*(2.0_wp*k+1.0_wp)) r1 = d(k+1)*r y2f = y2f + r1 if ( abs(r1)<=eps*abs(y2f) .and. k>30 ) exit enddo y2f = x*y2f y2d = 1.0_wp r = 1.0_wp do k = 1 , 79 r = 0.5_wp*r*x*x/(k*(2.0_wp*k-1.0_wp)) r1 = d(k+1)*r y2d = y2d + r1 if ( abs(r1)<=eps*abs(y2f) .and. k>30 ) exit enddo W1f = p0*(f1*y1f-f2*y2f) W2f = p0*(f1*y1f+f2*y2f) W1d = p0*(f1*y1d-f2*y2d) W2d = p0*(f1*y1d+f2*y2d) end subroutine rmn1(m,n,c,x,Df,Kd,R1f,R1d) ! ! ======================================================= ! Purpose: Compute prolate and oblate spheroidal radial ! functions of the first kind for given m, n, ! c and x ! Routines called: ! (1) SCKB for computing expansion coefficients c2k ! (2) SPHJ for computing the spherical Bessel ! functions of the first kind ! ======================================================= ! implicit none real(wp) a0 , b0 , c , ck , cx , Df , dj , eps , r , r0 , & & r1 , R1d , R1f , r2 , r3 , reg , sa0 , sj , suc ,& & sud real(wp) sum , sw , sw1 , x integer ip , j , k , Kd , l , lg , m , n , nm , nm1 , nm2 , np dimension ck(200) , Df(200) , sj(0:251) , dj(0:251) eps = 1.0d-14 ip = 1 nm1 = int((n-m)/2) if ( n-m==2*nm1 ) ip = 0 nm = 25 + nm1 + int(c) reg = 1.0_wp if ( m+nm>80 ) reg = 1.0d-200 r0 = reg do j = 1 , 2*m + ip r0 = r0*j enddo r = r0 suc = r*Df(1) sw = 0.0_wp do k = 2 , nm r = r*(m+k-1.0)*(m+k+ip-1.5d0)/(k-1.0_wp)/(k+ip-1.5d0) suc = suc + r*Df(k) if ( k>nm1 .and. abs(suc-sw)<abs(suc)*eps ) exit sw = suc enddo if ( x==0.0 ) then call sckb(m,n,c,Df,ck) sum = 0.0_wp sw1 = 0.0_wp do j = 1 , nm sum = sum + ck(j) if ( abs(sum-sw1)<abs(sum)*eps ) exit sw1 = sum enddo r1 = 1.0_wp do j = 1 , (n+m+ip)/2 r1 = r1*(j+0.5_wp*(n+m+ip)) enddo r2 = 1.0_wp do j = 1 , m r2 = 2.0_wp*c*r2*j enddo r3 = 1.0_wp do j = 1 , (n-m-ip)/2 r3 = r3*j enddo sa0 = (2.0*(m+ip)+1.0)*r1/(2.0**n*c**ip*r2*r3) if ( ip==0 ) then R1f = sum/(sa0*suc)*Df(1)*reg R1d = 0.0_wp elseif ( ip==1 ) then R1f = 0.0_wp R1d = sum/(sa0*suc)*Df(1)*reg endif return endif cx = c*x nm2 = 2*nm + m call sphj(nm2,cx,nm2,sj,dj) a0 = (1.0_wp-Kd/(x*x))**(0.5_wp*m)/suc R1f = 0.0_wp sw = 0.0_wp lg = 0 do k = 1 , nm l = 2*k + m - n - 2 + ip if ( l==4*int(l/4) ) lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0)*(m+k+ip-1.5d0)/(k-1.0_wp)/(k+ip-1.5d0) endif np = m + 2*k - 2 + ip R1f = R1f + lg*r*Df(k)*sj(np) if ( k>nm1 .and. abs(R1f-sw)<abs(R1f)*eps ) exit sw = R1f enddo R1f = R1f*a0 b0 = Kd*m/x**3.0_wp/(1.0-Kd/(x*x))*R1f sud = 0.0_wp sw = 0.0_wp do k = 1 , nm l = 2*k + m - n - 2 + ip if ( l==4*int(l/4) ) lg = 1 if ( l/=4*int(l/4) ) lg = -1 if ( k==1 ) then r = r0 else r = r*(m+k-1.0)*(m+k+ip-1.5d0)/(k-1.0_wp)/(k+ip-1.5d0) endif np = m + 2*k - 2 + ip sud = sud + lg*r*Df(k)*dj(np) if ( k>nm1 .and. abs(sud-sw)<abs(sud)*eps ) exit sw = sud enddo R1d = b0 + a0*c*sud end subroutine dvsa(Va,x,Pd) ! ! =================================================== ! Purpose: Compute parabolic cylinder function Dv(x) ! for small argument ! Input: x --- Argument ! va --- Order ! Output: PD --- Dv(x) ! Routine called: GAMMA2 for computing Г(x) ! =================================================== ! implicit none real(wp) a0 , ep , eps , g0 , g1 , ga0 , gm , Pd , & & r , r1 , sq2 , Va , va0 , vm , vt , x integer m eps = 1.0d-15 sq2 = sqrt(2.0_wp) ep = exp(-0.25_wp*x*x) va0 = 0.5_wp*(1.0_wp-Va) if ( Va==0.0 ) then Pd = ep elseif ( x==0.0 ) then if ( va0<=0.0 .and. va0==int(va0) ) then Pd = 0.0_wp else call gamma2(va0,ga0) Pd = sqrtpi/(2.0_wp**(-0.5_wp*Va)*ga0) endif else call gamma2(-Va,g1) a0 = 2.0_wp**(-0.5_wp*Va-1.0_wp)*ep/g1 vt = -0.5_wp*Va call gamma2(vt,g0) Pd = g0 r = 1.0_wp do m = 1 , 250 vm = .5d0*(m-Va) call gamma2(vm,gm) r = -r*sq2*x/m r1 = gm*r Pd = Pd + r1 if ( abs(r1)<abs(Pd)*eps ) exit enddo Pd = a0*Pd endif end subroutine e1z(z,Ce1) ! ! ==================================================== ! Purpose: Compute complex exponential integral E1(z) ! Input : z --- Argument of E1(z) ! Output: CE1 --- E1(z) ! ==================================================== ! implicit none real(wp) a0 , el , x , xt complex(wp) Ce1 , cr , z , zc , zd , zdc integer k el = 0.5772156649015328d0 x = real(z,wp) a0 = abs(z) ! Continued fraction converges slowly near negative real axis, ! so use power series in a wedge around it until radius 40.0 xt = -2*abs(aimag(z)) if ( a0==0.0_wp ) then Ce1 = (1.0e+300_wp,0.0_wp) elseif ( a0<=5.0 .or. x<xt .and. a0<40.0 ) then ! Power series Ce1 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 500 cr = -cr*k*z/(k+1.0_wp)**2 Ce1 = Ce1 + cr if ( abs(cr)<=abs(Ce1)*1.0d-15 ) exit enddo if ( x<=0.0 .and. aimag(z)==0.0 ) then ! Careful on the branch cut -- use the sign of the imaginary part ! to get the right sign on the factor if pi. Ce1 = -el - log(-z) + z*Ce1 - sign(pi,aimag(z)) & & *(0.0_wp,1.0_wp) else Ce1 = -el - log(z) + z*Ce1 endif else ! Continued fraction https://dlmf.nist.gov/6.9 ! ! 1 1 1 2 2 3 3 ! E1 = exp(-z) * ----- ----- ----- ----- ----- ----- ----- ... ! Z + 1 + Z + 1 + Z + 1 + Z + zc = 0d0 zd = 1/z zdc = 1*zd zc = zc + zdc do k = 1 , 500 zd = 1/(zd*k+1) zdc = (1*zd-1)*zdc zc = zc + zdc zd = 1/(zd*k+z) zdc = (z*zd-1)*zdc zc = zc + zdc if ( abs(zdc)<=abs(zc)*1.0d-15 .and. k>20 ) exit enddo Ce1 = exp(-z)*zc if ( x<=0.0 .and. aimag(z)==0.0 ) Ce1 = Ce1 - pi*(0.0_wp,1.0_wp) endif end subroutine itjyb(x,Tj,Ty) ! ! ======================================================= ! Purpose: Integrate Bessel functions J0(t) and Y0(t) ! with respect to t from 0 to x ( x ≥ 0 ) ! Input : x --- Upper limit of the integral ! Output: TJ --- Integration of J0(t) from 0 to x ! TY --- Integration of Y0(t) from 0 to x ! ======================================================= ! implicit none real(wp) f0 , g0 , t , Tj , Ty , x , x1 , xt if ( x==0.0_wp ) then Tj = 0.0_wp Ty = 0.0_wp elseif ( x<=4.0_wp ) then x1 = x/4.0_wp t = x1*x1 Tj = (((((((-.133718d-3*t+.2362211d-2)*t-.025791036d0)*t+ & & .197492634d0)*t-1.015860606d0)*t+3.199997842d0) & & *t-5.333333161d0)*t+4.0_wp)*x1 Ty = ((((((((.13351d-4*t-.235002d-3)*t+.3034322d-2)*t- & & .029600855d0)*t+.203380298d0)*t-.904755062d0) & & *t+2.287317974d0)*t-2.567250468d0)*t+1.076611469d0)*x1 Ty = 2.0_wp/pi*log(x/2.0_wp)*Tj - Ty elseif ( x<=8.0_wp ) then xt = x - .25d0*pi t = 16.0d0/(x*x) f0 = ((((((.1496119d-2*t-.739083d-2)*t+.016236617d0)*t- & & .022007499d0)*t+.023644978d0)*t-.031280848d0) & & *t+.124611058d0)*4.0_wp/x g0 = (((((.1076103d-2*t-.5434851d-2)*t+.01242264d0)*t- & & .018255209)*t+.023664841d0)*t-.049635633d0) & & *t + .79784879d0 Tj = 1.0_wp - (f0*cos(xt)-g0*sin(xt))/sqrt(x) Ty = -(f0*sin(xt)+g0*cos(xt))/sqrt(x) else t = 64.0d0/(x*x) xt = x - .25d0*pi f0 = (((((((-.268482d-4*t+.1270039d-3)*t-.2755037d-3)*t+ & & .3992825d-3)*t-.5366169d-3)*t+.10089872d-2) & & *t-.40403539d-2)*t+.0623347304d0)*8.0_wp/x g0 = ((((((-.226238d-4*t+.1107299d-3)*t-.2543955d-3)*t+ & & .4100676d-3)*t-.6740148d-3)*t+.17870944d-2) & & *t-.01256424405d0)*t + .79788456d0 Tj = 1.0_wp - (f0*cos(xt)-g0*sin(xt))/sqrt(x) Ty = -(f0*sin(xt)+g0*cos(xt))/sqrt(x) endif end subroutine chgul(a,b,x,Hu,Id) ! ! ======================================================= ! Purpose: Compute the confluent hypergeometric function ! U(a,b,x) for large argument x ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ! Output: HU --- U(a,b,x) ! ID --- Estimated number of significant digits ! ======================================================= ! implicit none real(wp) a , aa , b , Hu , r , r0 , ra , x integer Id , k , nm logical il1 , il2 Id = -100 aa = a - b + 1.0_wp il1 = a==int(a) .and. a<=0.0 il2 = aa==int(aa) .and. aa<=0.0 nm = 0 if ( il1 ) nm = abs(a) if ( il2 ) nm = abs(aa) ! IL1: DLMF 13.2.7 with k=-s-a ! IL2: DLMF 13.2.8 if ( il1 .or. il2 ) then Hu = 1.0_wp r = 1.0_wp do k = 1 , nm r = -r*(a+k-1.0_wp)*(a-b+k)/(k*x) Hu = Hu + r enddo Hu = x**(-a)*Hu Id = 10 else ! DLMF 13.7.3 Hu = 1.0_wp r = 1.0_wp do k = 1 , 25 r = -r*(a+k-1.0_wp)*(a-b+k)/(k*x) ra = abs(r) if ( k>5 .and. ra>=r0 .or. ra<1.0d-15 ) exit r0 = ra Hu = Hu + r enddo Id = abs(log10(ra)) Hu = x**(-a)*Hu endif end subroutine gmn(m,n,c,x,Bk,Gf,Gd) ! ! =========================================================== ! Purpose: Compute gmn(-ic,ix) and its derivative for oblate ! radial functions with a small argument ! =========================================================== ! implicit none real(wp) Bk , c , eps , Gd , gd0 , gd1 , Gf , gf0 , gw , & & x , xm integer ip , k , m , n , nm dimension Bk(200) eps = 1.0d-14 ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 nm = 25 + int(0.5*(n-m)+c) xm = (1.0_wp+x*x)**(-0.5_wp*m) gf0 = 0.0_wp gw = 0.0_wp do k = 1 , nm gf0 = gf0 + Bk(k)*x**(2.0*k-2.0) if ( abs((gf0-gw)/gf0)<eps .and. k>=10 ) exit gw = gf0 enddo Gf = xm*gf0*x**(1-ip) gd1 = -m*x/(1.0_wp+x*x)*Gf gd0 = 0.0_wp do k = 1 , nm if ( ip==0 ) then gd0 = gd0 + (2.0_wp*k-1.0)*Bk(k)*x**(2.0*k-2.0) else gd0 = gd0 + 2.0_wp*k*Bk(k+1)*x**(2.0*k-1.0) endif if ( abs((gd0-gw)/gd0)<eps .and. k>=10 ) exit gw = gd0 enddo Gd = gd1 + xm*gd0 end subroutine itjya(x,Tj,Ty) ! ! ========================================================== ! Purpose: Integrate Bessel functions J0(t) & Y0(t) with ! respect to t from 0 to x ! Input : x --- Upper limit of the integral ( x >= 0 ) ! Output: TJ --- Integration of J0(t) from 0 to x ! TY --- Integration of Y0(t) from 0 to x ! ======================================================= ! implicit none real(wp) a , a0 , a1 , af , bf , bg , el , eps , r , & & r2 , rc , rs , Tj , Ty , ty1 , ty2 , x , x2 , xp integer k dimension a(18) el = .5772156649015329d0 eps = 1.0d-12 if ( x==0.0_wp ) then Tj = 0.0_wp Ty = 0.0_wp elseif ( x<=20.0d0 ) then x2 = x*x Tj = x r = x do k = 1 , 60 r = -0.25_wp*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 Tj = Tj + r if ( abs(r)<abs(Tj)*eps ) exit enddo ty1 = (el+log(x/2.0_wp))*Tj rs = 0.0_wp ty2 = 1.0_wp r = 1.0_wp do k = 1 , 60 r = -0.25_wp*r*(2*k-1.0_wp)/(2*k+1.0_wp)/(k*k)*x2 rs = rs + 1.0_wp/k r2 = r*(rs+1.0_wp/(2.0_wp*k+1.0_wp)) ty2 = ty2 + r2 if ( abs(r2)<abs(ty2)*eps ) exit enddo Ty = (ty1-x*ty2)*2.0_wp/pi else a0 = 1.0_wp a1 = 5.0_wp/8.0_wp a(1) = a1 do k = 1 , 16 af = ((1.5d0*(k+.5d0)*(k+5.0_wp/6.0_wp)*a1-0.5_wp*(k+.5d0) & & *(k+.5d0)*(k-0.5_wp)*a0))/(k+1.0_wp) a(k+1) = af a0 = a1 a1 = af enddo bf = 1.0_wp r = 1.0_wp do k = 1 , 8 r = -r/(x*x) bf = bf + a(2*k)*r enddo bg = a(1)/x r = 1.0_wp/x do k = 1 , 8 r = -r/(x*x) bg = bg + a(2*k+1)*r enddo xp = x + .25d0*pi rc = sqrt(2.0_wp/(pi*x)) Tj = 1.0_wp - rc*(bf*cos(xp)+bg*sin(xp)) Ty = rc*(bg*cos(xp)-bf*sin(xp)) endif end subroutine rcty(n,x,Nm,Ry,Dy) ! ! ======================================================== ! Purpose: Compute Riccati-Bessel functions of the second ! kind and their derivatives ! Input: x --- Argument of Riccati-Bessel function ! n --- Order of yn(x) ! Output: RY(n) --- x·yn(x) ! DY(n) --- [x·yn(x)]' ! NM --- Highest order computed ! ======================================================== ! implicit none real(wp) Dy , rf0 , rf1 , rf2 , Ry , x integer k , n , Nm dimension Ry(0:n) , Dy(0:n) Nm = n if ( x<1.0d-60 ) then do k = 0 , n Ry(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo Ry(0) = -1.0_wp Dy(0) = 0.0_wp return endif Ry(0) = -cos(x) Ry(1) = Ry(0)/x - sin(x) rf0 = Ry(0) rf1 = Ry(1) do k = 2 , n rf2 = (2.0_wp*k-1.0_wp)*rf1/x - rf0 if ( abs(rf2)>1.0e+300_wp ) exit Ry(k) = rf2 rf0 = rf1 rf1 = rf2 enddo Nm = k - 1 Dy(0) = sin(x) do k = 1 , Nm Dy(k) = -k*Ry(k)/x + Ry(k-1) enddo end subroutine lpni(n,x,Pn,Pd,Pl) ! ! ===================================================== ! Purpose: Compute Legendre polynomials Pn(x), Pn'(x) ! and the integral of Pn(t) from 0 to x ! Input : x --- Argument of Pn(x) ! n --- Degree of Pn(x) ( n = 0,1,... ) ! Output: PN(n) --- Pn(x) ! PD(n) --- Pn'(x) ! PL(n) --- Integral of Pn(t) from 0 to x ! ===================================================== ! implicit none integer j , k , n , n1 real(wp) p0 , p1 , Pd , pf , Pl , Pn , r , x dimension Pn(0:n) , Pd(0:n) , Pl(0:n) Pn(0) = 1.0_wp Pn(1) = x Pd(0) = 0.0_wp Pd(1) = 1.0_wp Pl(0) = x Pl(1) = 0.5_wp*x*x p0 = 1.0_wp p1 = x do k = 2 , n pf = (2.0_wp*k-1.0_wp)/k*x*p1 - (k-1.0_wp)/k*p0 Pn(k) = pf if ( abs(x)==1.0_wp ) then Pd(k) = 0.5_wp*x**(k+1)*k*(k+1.0_wp) else Pd(k) = k*(p1-x*pf)/(1.0_wp-x*x) endif Pl(k) = (x*Pn(k)-Pn(k-1))/(k+1.0_wp) p0 = p1 p1 = pf if ( k/=2*int(k/2) ) then r = 1.0_wp/(k+1.0_wp) n1 = (k-1)/2 do j = 1 , n1 r = (0.5_wp/j-1.0_wp)*r enddo Pl(k) = Pl(k) + r endif enddo end subroutine klvna(x,Ber,Bei,Ger,Gei,Der,Dei,Her,Hei) ! ! ====================================================== ! Purpose: Compute Kelvin functions ber x, bei x, ker x ! and kei x, and their derivatives ( x > 0 ) ! Input : x --- Argument of Kelvin functions ! Output: BER --- ber x ! BEI --- bei x ! GER --- ker x ! GEI --- kei x ! DER --- ber'x ! DEI --- bei'x ! HER --- ker'x ! HEI --- kei'x ! ================================================ ! implicit none real(wp) Bei , Ber , cn0 , cp0 , cs , Dei , Der , el , & & eps , fac , Gei , Ger , gs , Hei , Her , & & pn0 , pn1 , pp0 , pp1 real(wp) qn0 , qn1 , qp0 , qp1 , r , r0 , r1 , rc , rs , & & sn0 , sp0 , ss , x , x2 , x4 , xc1 , xc2 , xd , & & xe1 , xe2 real(wp) xt integer k , km , m el = .5772156649015329d0 eps = 1.0d-15 if ( x==0.0_wp ) then Ber = 1.0_wp Bei = 0.0_wp Ger = 1.0e+300_wp Gei = -0.25d0*pi Der = 0.0_wp Dei = 0.0_wp Her = -1.0e+300_wp Hei = 0.0_wp return endif x2 = 0.25d0*x*x x4 = x2*x2 if ( abs(x)<10.0_wp ) then Ber = 1.0_wp r = 1.0_wp do m = 1 , 60 r = -0.25d0*r/(m*m)/(2.0_wp*m-1.0_wp)**2*x4 Ber = Ber + r if ( abs(r)<abs(Ber)*eps ) exit enddo Bei = x2 r = x2 do m = 1 , 60 r = -0.25d0*r/(m*m)/(2.0_wp*m+1.0_wp)**2*x4 Bei = Bei + r if ( abs(r)<abs(Bei)*eps ) exit enddo Ger = -(log(x/2.0_wp)+el)*Ber + 0.25d0*pi*Bei r = 1.0_wp gs = 0.0_wp do m = 1 , 60 r = -0.25d0*r/(m*m)/(2.0_wp*m-1.0_wp)**2*x4 gs = gs + 1.0_wp/(2.0_wp*m-1.0_wp) + 1.0_wp/(2.0_wp*m) Ger = Ger + r*gs if ( abs(r*gs)<abs(Ger)*eps ) exit enddo Gei = x2 - (log(x/2.0_wp)+el)*Bei - 0.25d0*pi*Ber r = x2 gs = 1.0_wp do m = 1 , 60 r = -0.25d0*r/(m*m)/(2.0_wp*m+1.0_wp)**2*x4 gs = gs + 1.0_wp/(2.0_wp*m) + 1.0_wp/(2.0_wp*m+1.0_wp) Gei = Gei + r*gs if ( abs(r*gs)<abs(Gei)*eps ) exit enddo Der = -0.25d0*x*x2 r = Der do m = 1 , 60 r = -0.25d0*r/m/(m+1.0_wp)/(2.0_wp*m+1.0_wp)**2*x4 Der = Der + r if ( abs(r)<abs(Der)*eps ) exit enddo Dei = 0.5_wp*x r = Dei do m = 1 , 60 r = -0.25d0*r/(m*m)/(2.d0*m-1.d0)/(2.d0*m+1.d0)*x4 Dei = Dei + r if ( abs(r)<abs(Dei)*eps ) exit enddo r = -0.25d0*x*x2 gs = 1.5d0 Her = 1.5d0*r - Ber/x - (log(x/2.d0)+el)*Der + 0.25*pi*Dei do m = 1 , 60 r = -0.25d0*r/m/(m+1.0_wp)/(2.0_wp*m+1.0_wp)**2*x4 gs = gs + 1.0_wp/(2*m+1.0_wp) + 1.0_wp/(2*m+2.0_wp) Her = Her + r*gs if ( abs(r*gs)<abs(Her)*eps ) exit enddo r = 0.5_wp*x gs = 1.0_wp Hei = 0.5_wp*x - Bei/x - (log(x/2.d0)+el)*Dei - 0.25*pi*Der do m = 1 , 60 r = -0.25d0*r/(m*m)/(2*m-1.0_wp)/(2*m+1.0_wp)*x4 gs = gs + 1.0_wp/(2.0_wp*m) + 1.0_wp/(2*m+1.0_wp) Hei = Hei + r*gs if ( abs(r*gs)<abs(Hei)*eps ) return enddo else pp0 = 1.0_wp pn0 = 1.0_wp qp0 = 0.0_wp qn0 = 0.0_wp r0 = 1.0_wp km = 18 if ( abs(x)>=40.0 ) km = 10 fac = 1.0_wp do k = 1 , km fac = -fac xt = 0.25d0*k*pi - int(0.125d0*k)*2.0_wp*pi cs = cos(xt) ss = sin(xt) r0 = 0.125d0*r0*(2.0_wp*k-1.0_wp)**2/k/x rc = r0*cs rs = r0*ss pp0 = pp0 + rc pn0 = pn0 + fac*rc qp0 = qp0 + rs qn0 = qn0 + fac*rs enddo xd = x/sqrt(2.0_wp) xe1 = exp(xd) xe2 = exp(-xd) xc1 = 1.d0/sqrt(2.0_wp*pi*x) xc2 = sqrt(0.5_wp*pi/x) cp0 = cos(xd+0.125d0*pi) cn0 = cos(xd-0.125d0*pi) sp0 = sin(xd+0.125d0*pi) sn0 = sin(xd-0.125d0*pi) Ger = xc2*xe2*(pn0*cp0-qn0*sp0) Gei = xc2*xe2*(-pn0*sp0-qn0*cp0) Ber = xc1*xe1*(pp0*cn0+qp0*sn0) - Gei/pi Bei = xc1*xe1*(pp0*sn0-qp0*cn0) + Ger/pi pp1 = 1.0_wp pn1 = 1.0_wp qp1 = 0.0_wp qn1 = 0.0_wp r1 = 1.0_wp fac = 1.0_wp do k = 1 , km fac = -fac xt = 0.25d0*k*pi - int(0.125d0*k)*2.0_wp*pi cs = cos(xt) ss = sin(xt) r1 = 0.125d0*r1*(4.d0-(2.0_wp*k-1.0_wp)**2)/k/x rc = r1*cs rs = r1*ss pp1 = pp1 + fac*rc pn1 = pn1 + rc qp1 = qp1 + fac*rs qn1 = qn1 + rs enddo Her = xc2*xe2*(-pn1*cn0+qn1*sn0) Hei = xc2*xe2*(pn1*sn0+qn1*cn0) Der = xc1*xe1*(pp1*cp0+qp1*sp0) - Hei/pi Dei = xc1*xe1*(pp1*sp0-qp1*cp0) + Her/pi endif end subroutine chgubi(a,b,x,Hu,Id) ! ! ====================================================== ! Purpose: Compute confluent hypergeometric function ! U(a,b,x) with integer b ( b = ±1,±2,... ) ! Input : a --- Parameter ! b --- Parameter ! x --- Argument ! Output: HU --- U(a,b,x) ! ID --- Estimated number of significant digits ! Routines called: ! (1) GAMMA2 for computing gamma function Г(x) ! (2) PSI_SPEC for computing psi function ! ====================================================== ! implicit none real(wp) a , a0 , a1 , a2 , b , da1 , da2 , db1 , db2 , & & el , ga , ga1 , h0 , hm1 , hm2 , hm3 , hmax , & & hmin , Hu , hu1 real(wp) hu2 , hw , ps , r , rn , rn1 , s0 , s1 , s2 , & & sa , sb , ua , ub , x integer Id , id1 , id2 , j , k , m , n Id = -100 el = 0.5772156649015329d0 n = abs(b-1) rn1 = 1.0_wp rn = 1.0_wp do j = 1 , n rn = rn*j if ( j==n-1 ) rn1 = rn enddo call psi_spec(a,ps) call gamma2(a,ga) if ( b>0.0 ) then a0 = a a1 = a - n a2 = a1 call gamma2(a1,ga1) ua = (-1)**(n-1)/(rn*ga1) ub = rn1/ga*x**(-n) else a0 = a + n a1 = a0 a2 = a call gamma2(a1,ga1) ua = (-1)**(n-1)/(rn*ga)*x**n ub = rn1/ga1 endif hm1 = 1.0_wp r = 1.0_wp hmax = 0.0_wp hmin = 1.0e+300_wp h0 = 0d0 do k = 1 , 150 r = r*(a0+k-1.0_wp)*x/((n+k)*k) hm1 = hm1 + r hu1 = abs(hm1) if ( hu1>hmax ) hmax = hu1 if ( hu1<hmin ) hmin = hu1 if ( abs(hm1-h0)<abs(hm1)*1.0d-15 ) exit h0 = hm1 enddo da1 = log10(hmax) da2 = 0.0_wp if ( hmin/=0.0 ) da2 = log10(hmin) Id = 15 - abs(da1-da2) hm1 = hm1*log(x) s0 = 0.0_wp do m = 1 , n if ( b>=0.0 ) s0 = s0 - 1.0_wp/m if ( b<0.0 ) s0 = s0 + (1.0_wp-a)/(m*(a+m-1.0_wp)) enddo hm2 = ps + 2.0_wp*el + s0 r = 1.0_wp hmax = 0.0_wp hmin = 1.0e+300_wp do k = 1 , 150 s1 = 0.0_wp s2 = 0.0_wp if ( b>0.0 ) then do m = 1 , k s1 = s1 - (m+2.0_wp*a-2.0_wp)/(m*(m+a-1.0_wp)) enddo do m = 1 , n s2 = s2 + 1.0_wp/(k+m) enddo else do m = 1 , k + n s1 = s1 + (1.0_wp-a)/(m*(m+a-1.0_wp)) enddo do m = 1 , k s2 = s2 + 1.0_wp/m enddo endif hw = 2.0_wp*el + ps + s1 - s2 r = r*(a0+k-1.0_wp)*x/((n+k)*k) hm2 = hm2 + r*hw hu2 = abs(hm2) if ( hu2>hmax ) hmax = hu2 if ( hu2<hmin ) hmin = hu2 if ( abs((hm2-h0)/hm2)<1.0d-15 ) exit h0 = hm2 enddo db1 = log10(hmax) db2 = 0.0_wp if ( hmin/=0.0 ) db2 = log10(hmin) id1 = 15 - abs(db1-db2) if ( id1<Id ) Id = id1 hm3 = 1.0_wp if ( n==0 ) hm3 = 0.0_wp r = 1.0_wp do k = 1 , n - 1 r = r*(a2+k-1.0_wp)/((k-n)*k)*x hm3 = hm3 + r enddo sa = ua*(hm1+hm2) sb = ub*hm3 Hu = sa + sb id2 = 0.0_wp if ( sa/=0.0 ) id1 = int(log10(abs(sa))) if ( Hu/=0.0 ) id2 = int(log10(abs(Hu))) if ( sa*sb<0.0 ) Id = Id - abs(id1-id2) end subroutine cyzo(Nt,Kf,Kc,Zo,Zv) ! ! =========================================================== ! Purpose : Compute the complex zeros of Y0(z), Y1(z) and ! Y1'(z), and their associated values at the zeros ! using the modified Newton's iteration method ! Input: NT --- Total number of zeros/roots ! KF --- Function choice code ! KF=0 for Y0(z) & Y1(z0) ! KF=1 for Y1(z) & Y0(z1) ! KF=2 for Y1'(z) & Y1(z1') ! KC --- Choice code ! KC=0 for complex roots ! KC=1 for real roots ! Output: ZO(L) --- L-th zero of Y0(z) or Y1(z) or Y1'(z) ! ZV(L) --- Value of Y0'(z) or Y1'(z) or Y1(z) ! at the L-th zero ! Routine called: CY01 for computing Y0(z) and Y1(z), and ! their derivatives ! =========================================================== implicit none real(wp) h , w , w0 , x , y integer i , it , j , Kc , Kf , nr , Nt complex(wp) z , zd , zf , zfd , zgd , Zo , zp , zq , Zv , zw dimension Zo(Nt) , Zv(Nt) x = 0.0_wp y = 0.0_wp h = 0.0_wp if ( Kc==0 ) then x = -2.4d0 y = 0.54d0 h = 3.14d0 ! JW : is this pi ? elseif ( Kc==1 ) then x = 0.89 y = 0.0 h = -3.14 ! JW : is this pi ? endif if ( Kf==1 ) x = -0.503 if ( Kf==2 ) x = 0.577 z = dcmplx(x,y) w = 0.0_wp do nr = 1 , Nt if ( nr/=1 ) z = Zo(nr-1) - h it = 0 50 it = it + 1 call cy01(Kf,z,zf,zd) zp = (1.0_wp,0.0_wp) do i = 1 , nr - 1 zp = zp*(z-Zo(i)) enddo zfd = zf/zp zq = (0.0_wp,0.0_wp) do i = 1 , nr - 1 zw = (1.0_wp,0.0_wp) do j = 1 , nr - 1 if ( j/=i ) zw = zw*(z-Zo(j)) enddo zq = zq + zw enddo zgd = (zd-zq*zfd)/zp z = z - zfd/zgd w0 = w w = abs(z) if ( it<=50 .and. abs((w-w0)/w)>1.0d-12 ) goto 50 Zo(nr) = z enddo do i = 1 , Nt z = Zo(i) if ( Kf==0 .or. Kf==2 ) then call cy01(1,z,zf,zd) Zv(i) = zf elseif ( Kf==1 ) then call cy01(0,z,zf,zd) Zv(i) = zf endif enddo end subroutine klvnb(x,Ber,Bei,Ger,Gei,Der,Dei,Her,Hei) ! ! ====================================================== ! Purpose: Compute Kelvin functions ber x, bei x, ker x ! and kei x, and their derivatives ( x > 0 ) ! Input : x --- Argument of Kelvin functions ! Output: BER --- ber x ! BEI --- bei x ! GER --- ker x ! GEI --- kei x ! DER --- ber'x ! DEI --- bei'x ! HER --- ker'x ! HEI --- kei'x ! ================================================ ! implicit none real(wp) Bei , Ber , csn , csp , Dei , Der , fxi , fxr , & & Gei , Ger , Hei , Her , pni , pnr , ppi , & & ppr , ssn , ssp , t real(wp) t2 , tni , tnr , tpi , tpr , u , v , x , yc1 , & & yc2 , yd , ye1 , ye2 integer l if ( x==0.0_wp ) then Ber = 1.0_wp Bei = 0.0_wp Ger = 1.0e+300_wp Gei = -0.25_wp*pi Der = 0.0_wp Dei = 0.0_wp Her = -1.0e+300_wp Hei = 0.0_wp elseif ( x<8.0_wp ) then t = x/8.0_wp t2 = t*t u = t2*t2 Ber = ((((((-.901d-5*u+.122552d-2)*u-.08349609d0)*u+ & & 2.64191397d0)*u-32.36345652d0)*u+113.77777774d0) & & *u-64.0d0)*u + 1.0_wp Bei = t*t*((((((.11346d-3*u-.01103667d0)*u+.52185615d0)*u- & & 10.56765779d0)*u+72.81777742d0)*u-113.77777774d0) & & *u+16.0d0) Ger = ((((((-.2458d-4*u+.309699d-2)*u-.19636347d0)*u+ & & 5.65539121d0)*u-60.60977451d0)*u+171.36272133d0) & & *u-59.05819744d0)*u - .57721566d0 Ger = Ger - log(0.5_wp*x)*Ber + .25d0*pi*Bei Gei = t2*((((((.29532d-3*u-.02695875d0)*u+1.17509064d0)*u- & & 21.30060904d0)*u+124.2356965d0)*u-142.91827687d0) & & *u+6.76454936d0) Gei = Gei - log(0.5_wp*x)*Bei - .25d0*pi*Ber Der = x*t2* & & ((((((-.394d-5*u+.45957d-3)*u-.02609253d0)*u+.66047849d0)& & *u-6.0681481d0)*u+14.22222222d0)*u-4.0_wp) Dei = x*((((((.4609d-4*u-.379386d-2)*u+.14677204d0)*u- & & 2.31167514d0)*u+11.37777772d0)*u-10.66666666d0)*u+.5d0) Her = x*t2*((((((-.1075d-4*u+.116137d-2)*u-.06136358d0)*u+ & & 1.4138478d0)*u-11.36433272d0)*u+21.42034017d0) & & *u-3.69113734d0) Her = Her - log(0.5_wp*x)*Der - Ber/x + .25d0*pi*Dei Hei = x*((((((.11997d-3*u-.926707d-2)*u+.33049424d0)*u- & & 4.65950823d0)*u+19.41182758d0)*u-13.39858846d0) & & *u+.21139217d0) Hei = Hei - log(0.5_wp*x)*Dei - Bei/x - .25d0*pi*Der else t = 8.0_wp/x tnr = 0.0_wp tni = 0.0_wp do l = 1 , 2 v = (-1)**l*t tpr = ((((.6d-6*v-.34d-5)*v-.252d-4)*v-.906d-4) & & *v*v+.0110486d0)*v tpi = ((((.19d-5*v+.51d-5)*v*v-.901d-4)*v-.9765d-3) & & *v-.0110485d0)*v - .3926991d0 if ( l==1 ) then tnr = tpr tni = tpi endif enddo yd = x/sqrt(2.0_wp) ye1 = exp(yd+tpr) ye2 = exp(-yd+tnr) yc1 = 1.0_wp/sqrt(2.0_wp*pi*x) yc2 = sqrt(pi/(2.0_wp*x)) csp = cos(yd+tpi) ssp = sin(yd+tpi) csn = cos(-yd+tni) ssn = sin(-yd+tni) Ger = yc2*ye2*csn Gei = yc2*ye2*ssn fxr = yc1*ye1*csp fxi = yc1*ye1*ssp Ber = fxr - Gei/pi Bei = fxi + Ger/pi pnr = 0.0_wp pni = 0.0_wp do l = 1 , 2 v = (-1)**l*t ppr = (((((.16d-5*v+.117d-4)*v+.346d-4)*v+.5d-6)*v-.13813d-2& & )*v-.0625001d0)*v + .7071068d0 ppi = (((((-.32d-5*v-.24d-5)*v+.338d-4)*v+.2452d-3)*v+ & & .13811d-2)*v-.1d-6)*v + .7071068d0 if ( l==1 ) then pnr = ppr pni = ppi endif enddo Her = Gei*pni - Ger*pnr Hei = -(Gei*pnr+Ger*pni) Der = fxr*ppr - fxi*ppi - Hei/pi Dei = fxi*ppr + fxr*ppi + Her/pi endif end subroutine rmn2so(m,n,c,x,Cv,Df,Kd,R2f,R2d) ! ! ============================================================= ! Purpose: Compute oblate radial functions of the second kind ! with a small argument, Rmn(-ic,ix) & Rmn'(-ic,ix) ! Routines called: ! (1) SCKB for computing the expansion coefficients c2k ! (2) KMN for computing the joining factors ! (3) QSTAR for computing the factor defined in (15.7.3) ! (4) CBK for computing the the expansion coefficient ! defined in (15.7.6) ! (5) GMN for computing the function defined in (15.7.4) ! (6) RMN1 for computing the radial function of the first ! kind ! ============================================================= ! implicit none real(wp) bk , c , ck , ck1 , ck2 , Cv , Df , dn , eps , & & gd , gf , h0 , qs , qt , r1d , r1f , R2d , & & R2f , sum real(wp) sw , x integer ip , j , Kd , m , n , nm dimension bk(200) , ck(200) , Df(200) , dn(200) if ( abs(Df(1))<=1.0d-280 ) then R2f = 1.0e+300_wp R2d = 1.0e+300_wp return endif eps = 1.0d-14 nm = 25 + int((n-m)/2+c) ip = 1 if ( n-m==2*int((n-m)/2) ) ip = 0 call sckb(m,n,c,Df,ck) call kmn(m,n,c,Cv,Kd,Df,dn,ck1,ck2) call qstar(m,n,c,ck,ck1,qs,qt) call cbk(m,n,c,Cv,qt,ck,bk) if ( x==0.0_wp ) then sum = 0.0_wp sw = 0.0_wp do j = 1 , nm sum = sum + ck(j) if ( abs(sum-sw)<abs(sum)*eps ) exit sw = sum enddo if ( ip==0 ) then r1f = sum/ck1 R2f = -halfpi*qs*r1f R2d = qs*r1f + bk(1) elseif ( ip==1 ) then r1d = sum/ck1 R2f = bk(1) R2d = -halfpi*qs*r1d endif return else call gmn(m,n,c,x,bk,gf,gd) call rmn1(m,n,c,x,Df,Kd,r1f,r1d) h0 = atan(x) - halfpi R2f = qs*r1f*h0 + gf R2d = qs*(r1d*h0+r1f/(1.0_wp+x*x)) + gd endif end subroutine bjndd(n,x,Bj,Dj,Fj) ! ! ===================================================== ! Purpose: Compute Bessel functions Jn(x) and their ! first and second derivatives ( n= 0,1,… ) ! Input: x --- Argument of Jn(x) ( x ≥ 0 ) ! n --- Order of Jn(x) ! Output: BJ(n+1) --- Jn(x) ! DJ(n+1) --- Jn'(x) ! FJ(n+1) --- Jn"(x) ! ===================================================== ! implicit none real(wp) Bj , bs , Dj , f , f0 , f1 , Fj , x integer k , m , mt , n , nt dimension Bj(101) , Dj(101) , Fj(101) do nt = 1 , 900 mt = int(0.5*log10(6.28*nt)-nt*log10(1.36*abs(x)/nt)) if ( mt>20 ) exit enddo m = nt bs = 0.0_wp f = 0.0_wp f0 = 0.0_wp f1 = 1.0d-35 do k = m , 0 , -1 f = 2.0_wp*(k+1.0_wp)*f1/x - f0 if ( k<=n ) Bj(k+1) = f if ( k==2*int(k/2) ) bs = bs + 2.0_wp*f f0 = f1 f1 = f enddo do k = 0 , n Bj(k+1) = Bj(k+1)/(bs-f) enddo Dj(1) = -Bj(2) Fj(1) = -1.0_wp*Bj(1) - Dj(1)/x do k = 1 , n Dj(k+1) = Bj(k) - k*Bj(k+1)/x Fj(k+1) = (k*k/(x*x)-1.0_wp)*Bj(k+1) - Dj(k+1)/x enddo end subroutine sphj(n,x,Nm,Sj,Dj) ! MODIFIED to ALLOW N=0 CASE (ALSO IN SPHY) ! ! ======================================================= ! Purpose: Compute spherical Bessel functions jn(x) and ! their derivatives ! Input : x --- Argument of jn(x) ! n --- Order of jn(x) ( n = 0,1,… ) ! Output: SJ(n) --- jn(x) ! DJ(n) --- jn'(x) ! NM --- Highest order computed ! Routines called: ! MSTA1 and MSTA2 for computing the starting ! point for backward recurrence ! ======================================================= ! implicit none real(wp) cs , Dj , f , f0 , f1 , sa , sb , Sj , x integer k , m , n , Nm dimension Sj(0:n) , Dj(0:n) Nm = n if ( abs(x)<1.0d-100 ) then do k = 0 , n Sj(k) = 0.0_wp Dj(k) = 0.0_wp enddo Sj(0) = 1.0_wp if ( n>0 ) Dj(1) = .3333333333333333d0 return endif Sj(0) = sin(x)/x Dj(0) = (cos(x)-sin(x)/x)/x if ( n<1 ) return Sj(1) = (Sj(0)-cos(x))/x if ( n>=2 ) then sa = Sj(0) sb = Sj(1) m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f = 0.0_wp f0 = 0.0_wp f1 = 1.0_wp - 100 do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f1/x - f0 if ( k<=Nm ) Sj(k) = f f0 = f1 f1 = f enddo cs = 0.0_wp if ( abs(sa)>abs(sb) ) cs = sa/f if ( abs(sa)<=abs(sb) ) cs = sb/f0 do k = 0 , Nm Sj(k) = cs*Sj(k) enddo endif do k = 1 , Nm Dj(k) = Sj(k-1) - (k+1.0_wp)*Sj(k)/x enddo end subroutine othpl(Kf,n,x,Pl,Dpl) ! ! ========================================================== ! Purpose: Compute orthogonal polynomials: Tn(x) or Un(x), ! or Ln(x) or Hn(x), and their derivatives ! Input : KF --- Function code ! KF=1 for Chebyshev polynomial Tn(x) ! KF=2 for Chebyshev polynomial Un(x) ! KF=3 for Laguerre polynomial Ln(x) ! KF=4 for Hermite polynomial Hn(x) ! n --- Order of orthogonal polynomials ! x --- Argument of orthogonal polynomials ! Output: PL(n) --- Tn(x) or Un(x) or Ln(x) or Hn(x) ! DPL(n)--- Tn'(x) or Un'(x) or Ln'(x) or Hn'(x) ! ========================================================= ! implicit none real(wp) a , b , c , Dpl , dy0 , dy1 , dyn , Pl , x , y0 ,& & y1 , yn integer k , Kf , n dimension Pl(0:n) , Dpl(0:n) a = 2.0_wp b = 0.0_wp c = 1.0_wp y0 = 1.0_wp y1 = 2.0_wp*x dy0 = 0.0_wp dy1 = 2.0_wp Pl(0) = 1.0_wp Pl(1) = 2.0_wp*x Dpl(0) = 0.0_wp Dpl(1) = 2.0_wp if ( Kf==1 ) then y1 = x dy1 = 1.0_wp Pl(1) = x Dpl(1) = 1.0_wp elseif ( Kf==3 ) then y1 = 1.0_wp - x dy1 = -1.0_wp Pl(1) = 1.0_wp - x Dpl(1) = -1.0_wp endif do k = 2 , n if ( Kf==3 ) then a = -1.0_wp/k b = 2.0_wp + a c = 1.0_wp + a elseif ( Kf==4 ) then c = 2.0_wp*(k-1.0_wp) endif yn = (a*x+b)*y1 - c*y0 dyn = a*y1 + (a*x+b)*dy1 - c*dy0 Pl(k) = yn Dpl(k) = dyn y0 = y1 y1 = yn dy0 = dy1 dy1 = dyn enddo end subroutine klvnzo(Nt,Kd,Zo) ! ! ==================================================== ! Purpose: Compute the zeros of Kelvin functions ! Input : NT --- Total number of zeros ! KD --- Function code ! KD=1 to 8 for ber x, bei x, ker x, kei x, ! ber'x, bei'x, ker'x and kei'x, ! respectively. ! Output: ZO(M) --- the M-th zero of Kelvin function ! for code KD ! Routine called: ! KLVNA for computing Kelvin functions and ! their derivatives ! ==================================================== ! implicit none real(wp) bei , ber , ddi , ddr , dei , der , gdi , gdr , & & gei , ger , hei , her , rt , rt0 , Zo integer Kd , m , Nt dimension Zo(Nt) , rt0(8) rt0(1) = 2.84891 rt0(2) = 5.02622 rt0(3) = 1.71854 rt0(4) = 3.91467 rt0(5) = 6.03871 rt0(6) = 3.77268 rt0(7) = 2.66584 rt0(8) = 4.93181 rt = rt0(Kd) do m = 1 , Nt call klvna(rt,ber,bei,ger,gei,der,dei,her,hei) if ( Kd==1 ) then rt = rt - ber/der elseif ( Kd==2 ) then rt = rt - bei/dei elseif ( Kd==3 ) then rt = rt - ger/her elseif ( Kd==4 ) then rt = rt - gei/hei elseif ( Kd==5 ) then ddr = -bei - der/rt rt = rt - der/ddr elseif ( Kd==6 ) then ddi = ber - dei/rt rt = rt - dei/ddi elseif ( Kd==7 ) then gdr = -gei - her/rt rt = rt - her/gdr else gdi = ger - hei/rt rt = rt - hei/gdi endif if ( abs(rt-rt0(Kd))>5.0d-10 ) then rt0(Kd) = rt cycle endif Zo(m) = rt rt = rt + 4.44d0 enddo end subroutine rswfo(m,n,c,x,Cv,Kf,R1f,R1d,R2f,R2d) ! ! ========================================================== ! Purpose: Compute oblate radial functions of the first ! and second kinds, and their derivatives ! Input : m --- Mode parameter, m = 0,1,2,... ! n --- Mode parameter, n = m,m+1,m+2,... ! c --- Spheroidal parameter ! x --- Argument (x ≥ 0) ! cv --- Characteristic value ! KF --- Function code ! KF=1 for the first kind ! KF=2 for the second kind ! KF=3 for both the first and second kinds ! Output: R1F --- Radial function of the first kind ! R1D --- Derivative of the radial function of ! the first kind ! R2F --- Radial function of the second kind ! R2D --- Derivative of the radial function of ! the second kind ! Routines called: ! (1) SDMN for computing expansion coefficients dk ! (2) RMN1 for computing prolate or oblate radial ! function of the first kind ! (3) RMN2L for computing prolate or oblate radial ! function of the second kind for a large argument ! (4) RMN2SO for computing oblate radial functions of ! the second kind for a small argument ! ========================================================== ! implicit none real(wp) c , Cv , df , R1d , R1f , R2d , R2f , x integer id , kd , Kf , m , n dimension df(200) kd = -1 call sdmn(m,n,c,Cv,kd,df) if ( Kf/=2 ) call rmn1(m,n,c,x,df,kd,R1f,R1d) if ( Kf>1 ) then id = 10 if ( x>1.0d-8 ) call rmn2l(m,n,c,x,df,kd,R2f,R2d,id) if ( id>-1 ) call rmn2so(m,n,c,x,Cv,df,kd,R2f,R2d) endif end subroutine ch12n(n,z,Nm,Chf1,Chd1,Chf2,Chd2) ! ! ==================================================== ! Purpose: Compute Hankel functions of the first and ! second kinds and their derivatives for a ! complex argument ! Input : z --- Complex argument ! n --- Order of Hn(1)(z) and Hn(2)(z) ! Output: CHF1(n) --- Hn(1)(z) ! CHD1(n) --- Hn(1)'(z) ! CHF2(n) --- Hn(2)(z) ! CHD2(n) --- Hn(2)'(z) ! NM --- Highest order computed ! Routines called: ! (1) CJYNB for computing Jn(z) and Yn(z) ! (2) CIKNB for computing In(z) and Kn(z) ! ==================================================== ! implicit none complex(wp) cbi , cbj , cbk , cby , cdi , cdj , cdk , cdy , cf1 , & & cfac , Chd1 , Chd2 , Chf1 , Chf2 , ci , z , zi integer k , n , Nm dimension cbj(0:250) , cdj(0:250) , cby(0:250) , cdy(0:250) , & & cbi(0:250) , cdi(0:250) , cbk(0:250) , cdk(0:250) dimension Chf1(0:n) , Chd1(0:n) , Chf2(0:n) , Chd2(0:n) ci = (0.0_wp,1.0_wp) if ( aimag(z)<0.0_wp ) then call cjynb(n,z,Nm,cbj,cdj,cby,cdy) do k = 0 , Nm Chf1(k) = cbj(k) + ci*cby(k) Chd1(k) = cdj(k) + ci*cdy(k) enddo zi = ci*z call ciknb(n,zi,Nm,cbi,cdi,cbk,cdk) cfac = -2.0_wp/(pi*ci) do k = 0 , Nm Chf2(k) = cfac*cbk(k) Chd2(k) = cfac*ci*cdk(k) cfac = cfac*ci enddo elseif ( aimag(z)>0.0_wp ) then zi = -ci*z call ciknb(n,zi,Nm,cbi,cdi,cbk,cdk) cf1 = -ci cfac = 2.0_wp/(pi*ci) do k = 0 , Nm Chf1(k) = cfac*cbk(k) Chd1(k) = -cfac*ci*cdk(k) cfac = cfac*cf1 enddo call cjynb(n,z,Nm,cbj,cdj,cby,cdy) do k = 0 , Nm Chf2(k) = cbj(k) - ci*cby(k) Chd2(k) = cdj(k) - ci*cdy(k) enddo else call cjynb(n,z,Nm,cbj,cdj,cby,cdy) do k = 0 , Nm Chf1(k) = cbj(k) + ci*cby(k) Chd1(k) = cdj(k) + ci*cdy(k) Chf2(k) = cbj(k) - ci*cby(k) Chd2(k) = cdj(k) - ci*cdy(k) enddo endif end subroutine jyzo(n,Nt,Rj0,Rj1,Ry0,Ry1) ! ! ====================================================== ! Purpose: Compute the zeros of Bessel functions Jn(x), ! Yn(x), and their derivatives ! Input : n --- Order of Bessel functions (n >= 0) ! NT --- Number of zeros (roots) ! Output: RJ0(L) --- L-th zero of Jn(x), L=1,2,...,NT ! RJ1(L) --- L-th zero of Jn'(x), L=1,2,...,NT ! RY0(L) --- L-th zero of Yn(x), L=1,2,...,NT ! RY1(L) --- L-th zero of Yn'(x), L=1,2,...,NT ! Routine called: JYNDD for computing Jn(x), Yn(x), and ! their first and second derivatives ! ====================================================== ! implicit none real(wp) bjn , byn , djn , dyn , fjn , fyn , Rj0 , & & Rj1 , Ry0 , Ry1 , x , x0 , xguess integer l , n , Nt dimension Rj0(Nt) , Rj1(Nt) , Ry0(Nt) , Ry1(Nt) ! -- Newton method for j_{N,L} ! 1) initial guess for j_{N,1} if ( n<=20 ) then x = 2.82141 + 1.15859*n else ! Abr & Stg (9.5.14) x = n + 1.85576*n**0.33333 + 1.03315/n**0.33333 endif l = 0 ! 2) iterate xguess = x 100 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - bjn/djn if ( x-x0<-1 ) x = x0 - 1 if ( x-x0>1 ) x = x0 + 1 if ( abs(x-x0)>1.0d-11 ) goto 100 ! 3) initial guess for j_{N,L+1} if ( l>=1 ) then if ( x<=Rj0(l)+0.5 ) then x = xguess + pi xguess = x goto 100 endif endif l = l + 1 Rj0(l) = x ! XXX: should have a better initial guess for large N ~> 100 here x = x + pi + max((0.0972d0+0.0679*n-0.000354*n**2)/l,0d0) if ( l<Nt ) goto 100 ! -- Newton method for j_{N,L}' if ( n<=20 ) then x = 0.961587 + 1.07703*n else x = n + 0.80861*n**0.33333 + 0.07249/n**0.33333 endif if ( n==0 ) x = 3.8317 l = 0 xguess = x 200 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - djn/fjn if ( x-x0<-1 ) x = x0 - 1 if ( x-x0>1 ) x = x0 + 1 if ( abs(x-x0)>1.0d-11 ) goto 200 if ( l>=1 ) then if ( x<=Rj1(l)+0.5 ) then x = xguess + pi xguess = x goto 200 endif endif l = l + 1 Rj1(l) = x ! XXX: should have a better initial guess for large N ~> 100 here x = x + pi + max((0.4955d0+0.0915*n-0.000435*n**2)/l,0d0) if ( l<Nt ) goto 200 ! -- Newton method for y_{N,L} if ( n<=20 ) then x = 1.19477 + 1.08933*n else x = n + 0.93158*n**0.33333 + 0.26035/n**0.33333 endif l = 0 xguess = x 300 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - byn/dyn if ( x-x0<-1 ) x = x0 - 1 if ( x-x0>1 ) x = x0 + 1 if ( abs(x-x0)>1.0d-11 ) goto 300 if ( l>=1 ) then if ( x<=Ry0(l)+0.5 ) then x = xguess + pi xguess = x goto 300 endif endif l = l + 1 Ry0(l) = x ! XXX: should have a better initial guess for large N ~> 100 here x = x + pi + max((0.312d0+0.0852*n-0.000403*n**2)/l,0d0) if ( l<Nt ) goto 300 ! -- Newton method for y_{N,L}' if ( n<=20 ) then x = 2.67257 + 1.16099*n else x = n + 1.8211*n**0.33333 + 0.94001/n**0.33333 endif l = 0 xguess = x 400 x0 = x call jyndd(n,x,bjn,djn,fjn,byn,dyn,fyn) x = x - dyn/fyn if ( abs(x-x0)>1.0d-11 ) goto 400 if ( l>=1 ) then if ( x<=Ry1(l)+0.5 ) then x = xguess + pi xguess = x goto 400 endif endif l = l + 1 Ry1(l) = x ! XXX: should have a better initial guess for large N ~> 100 here x = x + pi + max((0.197d0+0.0643*n-0.000286*n**2)/l,0d0) if ( l<Nt ) goto 400 end subroutine ikv(v,x,Vm,Bi,Di,Bk,Dk) ! ! ======================================================= ! Purpose: Compute modified Bessel functions Iv(x) and ! Kv(x), and their derivatives ! Input : x --- Argument ( x ≥ 0 ) ! v --- Order of Iv(x) and Kv(x) ! ( v = n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) ! Output: BI(n) --- In+v0(x) ! DI(n) --- In+v0'(x) ! BK(n) --- Kn+v0(x) ! DK(n) --- Kn+v0'(x) ! VM --- Highest order computed ! Routines called: ! (1) GAMMA2 for computing the gamma function ! (2) MSTA1 and MSTA2 to compute the starting ! point for backward recurrence ! ======================================================= ! implicit none real(wp) a1 , a2 , Bi , bi0 , Bk , bk0 , bk1 , bk2 , ca , & & cb , cs , ct , Di , Dk , f , f1 , f2 , gan , & & gap real(wp) piv , r , r1 , r2 , sum , v , v0 , v0n , v0p , & & Vm , vt , w0 , wa , ww , x , x2 integer k , k0 , m , n dimension Bi(0:*) , Di(0:*) , Bk(0:*) , Dk(0:*) x2 = x*x n = int(v) v0 = v - n if ( n==0 ) n = 1 if ( x<1.0d-100 ) then do k = 0 , n Bi(k) = 0.0_wp Di(k) = 0.0_wp Bk(k) = -1.0e+300_wp Dk(k) = 1.0e+300_wp enddo if ( v==0.0 ) then Bi(0) = 1.0_wp Di(1) = 0.5_wp endif Vm = v return endif piv = pi*v0 vt = 4.0_wp*v0*v0 if ( v0==0.0_wp ) then a1 = 1.0_wp else v0p = 1.0_wp + v0 call gamma2(v0p,gap) a1 = (0.5_wp*x)**v0/gap endif k0 = 14 if ( x>=35.0 ) k0 = 10 if ( x>=50.0 ) k0 = 8 if ( x<=18.0 ) then bi0 = 1.0_wp r = 1.0_wp do k = 1 , 30 r = 0.25d0*r*x2/(k*(k+v0)) bi0 = bi0 + r if ( abs(r/bi0)<1.0d-15 ) exit enddo bi0 = bi0*a1 else ca = exp(x)/sqrt(2.0_wp*pi*x) sum = 1.0_wp r = 1.0_wp do k = 1 , k0 r = -0.125d0*r*(vt-(2.0_wp*k-1.0_wp)**2.0)/(k*x) sum = sum + r enddo bi0 = ca*sum endif m = msta1(x,200) if ( m<n ) then n = m else m = msta2(x,n,15) endif f = 0.0_wp f2 = 0.0_wp f1 = 1.0d-100 ww = 0.0_wp do k = m , 0 , -1 f = 2.0_wp*(v0+k+1.0_wp)/x*f1 + f2 if ( k<=n ) Bi(k) = f f2 = f1 f1 = f enddo cs = bi0/f do k = 0 , n Bi(k) = cs*Bi(k) enddo Di(0) = v0/x*Bi(0) + Bi(1) do k = 1 , n Di(k) = -(k+v0)/x*Bi(k) + Bi(k-1) enddo if ( x>9.0_wp ) then cb = exp(-x)*sqrt(halfpi/x) sum = 1.0_wp r = 1.0_wp do k = 1 , k0 r = 0.125d0*r*(vt-(2.0*k-1.0)**2.0)/(k*x) sum = sum + r enddo bk0 = cb*sum elseif ( v0==0.0_wp ) then ct = -log(0.5_wp*x) - 0.5772156649015329d0 cs = 0.0_wp w0 = 0.0_wp r = 1.0_wp do k = 1 , 50 w0 = w0 + 1.0_wp/k r = 0.25d0*r/(k*k)*x2 cs = cs + r*(w0+ct) wa = abs(cs) if ( abs((wa-ww)/wa)<1.0d-15 ) exit ww = wa enddo bk0 = ct + cs else v0n = 1.0_wp - v0 call gamma2(v0n,gan) a2 = 1.0_wp/(gan*(0.5_wp*x)**v0) a1 = (0.5_wp*x)**v0/gap sum = a2 - a1 r1 = 1.0_wp r2 = 1.0_wp do k = 1 , 120 r1 = 0.25d0*r1*x2/(k*(k-v0)) r2 = 0.25d0*r2*x2/(k*(k+v0)) sum = sum + a2*r1 - a1*r2 wa = abs(sum) if ( abs((wa-ww)/wa)<1.0d-15 ) exit ww = wa enddo bk0 = halfpi*sum/sin(piv) endif bk1 = (1.0_wp/x-Bi(1)*bk0)/Bi(0) Bk(0) = bk0 Bk(1) = bk1 do k = 2 , n bk2 = 2.0_wp*(v0+k-1.0_wp)/x*bk1 + bk0 Bk(k) = bk2 bk0 = bk1 bk1 = bk2 enddo Dk(0) = v0/x*Bk(0) - Bk(1) do k = 1 , n Dk(k) = -(k+v0)/x*Bk(k) - Bk(k-1) enddo Vm = n + v0 end subroutine sdmn(m,n,c,Cv,Kd,Df) ! ! ===================================================== ! Purpose: Compute the expansion coefficients of the ! prolate and oblate spheroidal functions, dk ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! cv --- Characteristic value ! KD --- Function code ! KD=1 for prolate; KD=-1 for oblate ! Output: DF(k) --- Expansion coefficients dk; ! DF(1), DF(2), ... correspond to ! d0, d2, ... for even n-m and d1, ! d3, ... for odd n-m ! ===================================================== ! implicit none real(wp) a , c , cs , Cv , d , d2k , Df , dk0 , dk1 , & & dk2 , f , f0 , f1 , f2 , fl , fs , g , r1 , r3 , & & r4 real(wp) s0 , su1 , su2 , sw integer i , ip , j , k , k1 , kb , Kd , m , n , nm dimension a(200) , d(200) , g(200) , Df(200) nm = 25 + int(0.5*(n-m)+c) if ( c<1.0d-10 ) then do i = 1 , nm Df(i) = 0d0 enddo Df((n-m)/2+1) = 1.0_wp return endif cs = c*c*Kd ip = 1 k = 0 if ( n-m==2*int((n-m)/2) ) ip = 0 do i = 1 , nm + 2 if ( ip==0 ) k = 2*(i-1) if ( ip==1 ) k = 2*i - 1 dk0 = m + k dk1 = m + k + 1 dk2 = 2*(m+k) d2k = 2*m + k a(i) = (d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs d(i) = dk0*dk1 + (2.0*dk0*dk1-2.0*m*m-1.0) & & /((dk2-1.0)*(dk2+3.0))*cs g(i) = k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs enddo fs = 1.0_wp f1 = 0.0_wp f0 = 1.0d-100 kb = 0 Df(nm+1) = 0.0_wp fl = 0.0_wp do k = nm , 1 , -1 f = -((d(k+1)-Cv)*f0+a(k+1)*f1)/g(k+1) if ( abs(f)>abs(Df(k+1)) ) then Df(k) = f f1 = f0 f0 = f if ( abs(f)>1.0d+100 ) then do k1 = k , nm Df(k1) = Df(k1)*1.0d-100 enddo f1 = f1*1.0d-100 f0 = f0*1.0d-100 endif else kb = k fl = Df(k+1) f1 = 1.0d-100 f2 = -(d(1)-Cv)/a(1)*f1 Df(1) = f1 if ( kb==1 ) then fs = f2 elseif ( kb==2 ) then Df(2) = f2 fs = -((d(2)-Cv)*f2+g(2)*f1)/a(2) else Df(2) = f2 do j = 3 , kb + 1 f = -((d(j-1)-Cv)*f2+g(j-1)*f1)/a(j-1) if ( j<=kb ) Df(j) = f if ( abs(f)>1.0d+100 ) then do k1 = 1 , j Df(k1) = Df(k1)*1.0d-100 enddo f = f*1.0d-100 f2 = f2*1.0d-100 endif f1 = f2 f2 = f enddo fs = f endif exit endif enddo su1 = 0.0_wp r1 = 1.0_wp do j = m + ip + 1 , 2*(m+ip) r1 = r1*j enddo su1 = Df(1)*r1 do k = 2 , kb r1 = -r1*(k+m+ip-1.5d0)/(k-1.0_wp) su1 = su1 + r1*Df(k) enddo su2 = 0.0_wp sw = 0.0_wp do k = kb + 1 , nm if ( k/=1 ) r1 = -r1*(k+m+ip-1.5d0)/(k-1.0_wp) su2 = su2 + r1*Df(k) if ( abs(sw-su2)<abs(su2)*1.0d-14 ) exit sw = su2 enddo r3 = 1.0_wp do j = 1 , (m+n+ip)/2 r3 = r3*(j+0.5_wp*(n+m+ip)) enddo r4 = 1.0_wp do j = 1 , (n-m-ip)/2 r4 = -4.0_wp*r4*j enddo s0 = r3/(fl*(su1/fs)+su2)/r4 do k = 1 , kb Df(k) = fl/fs*s0*Df(k) enddo do k = kb + 1 , nm Df(k) = s0*Df(k) enddo end subroutine ajyik(x,Vj1,Vj2,Vy1,Vy2,Vi1,Vi2,Vk1,Vk2) ! ! ======================================================= ! Purpose: Compute Bessel functions Jv(x) and Yv(x), ! and modified Bessel functions Iv(x) and ! Kv(x), and their derivatives with v=1/3,2/3 ! Input : x --- Argument of Jv(x),Yv(x),Iv(x) and ! Kv(x) ( x ≥ 0 ) ! Output: VJ1 --- J1/3(x) ! VJ2 --- J2/3(x) ! VY1 --- Y1/3(x) ! VY2 --- Y2/3(x) ! VI1 --- I1/3(x) ! VI2 --- I2/3(x) ! VK1 --- K1/3(x) ! VK2 --- K2/3(x) ! ======================================================= ! implicit none real(wp) a0 , b0 , c0 , ck , gn , gn1 , gn2 , gp1 , gp2 , & & pv1 , pv2 , px , qx , r , rp , rp2 , rq , & & sk , sum real(wp) uj1 , uj2 , uu0 , Vi1 , Vi2 , vil , Vj1 , Vj2 , & & vjl , Vk1 , Vk2 , vl , vsl , vv , vv0 , Vy1 , & & Vy2 , x , x2 , xk integer k , k0 , l if ( x==0.0_wp ) then Vj1 = 0.0_wp Vj2 = 0.0_wp Vy1 = -1.0e+300_wp Vy2 = 1.0e+300_wp Vi1 = 0.0_wp Vi2 = 0.0_wp Vk1 = -1.0e+300_wp Vk2 = -1.0e+300_wp return endif rp2 = .63661977236758d0 gp1 = .892979511569249d0 gp2 = .902745292950934d0 gn1 = 1.3541179394264d0 gn2 = 2.678938534707747d0 vv0 = 0.444444444444444d0 uu0 = 1.1547005383793d0 x2 = x*x k0 = 12 if ( x>=35.0 ) k0 = 10 if ( x>=50.0 ) k0 = 8 if ( x<=12.0 ) then do l = 1 , 2 vl = l/3.0_wp vjl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25d0*r*x2/(k*(k+vl)) vjl = vjl + r if ( abs(r)<1.0d-15 ) exit enddo a0 = (0.5_wp*x)**vl if ( l==1 ) Vj1 = a0/gp1*vjl if ( l==2 ) Vj2 = a0/gp2*vjl enddo else do l = 1 , 2 vv = vv0*l*l px = 1.0_wp rp = 1.0_wp do k = 1 , k0 rp = -0.78125d-2*rp*(vv-(4.0*k-3.0)**2.0) & & *(vv-(4.0*k-1.0)**2.0)/(k*(2.0*k-1.0)*x2) px = px + rp enddo qx = 1.0_wp rq = 1.0_wp do k = 1 , k0 rq = -0.78125d-2*rq*(vv-(4.0*k-1.0)**2.0) & & *(vv-(4.0*k+1.0)**2.0)/(k*(2.0*k+1.0)*x2) qx = qx + rq enddo qx = 0.125d0*(vv-1.0)*qx/x xk = x - (0.5_wp*l/3.0_wp+0.25d0)*pi a0 = sqrt(rp2/x) ck = cos(xk) sk = sin(xk) if ( l==1 ) then Vj1 = a0*(px*ck-qx*sk) Vy1 = a0*(px*sk+qx*ck) elseif ( l==2 ) then Vj2 = a0*(px*ck-qx*sk) Vy2 = a0*(px*sk+qx*ck) endif enddo endif if ( x<=12.0d0 ) then uj1 = 0.0_wp uj2 = 0.0_wp do l = 1 , 2 vl = l/3.0_wp vjl = 1.0_wp r = 1.0_wp do k = 1 , 40 r = -0.25d0*r*x2/(k*(k-vl)) vjl = vjl + r if ( abs(r)<1.0d-15 ) exit enddo b0 = (2.0_wp/x)**vl if ( l==1 ) uj1 = b0*vjl/gn1 if ( l==2 ) uj2 = b0*vjl/gn2 enddo pv1 = pi/3.0_wp pv2 = pi/1.5d0 Vy1 = uu0*(Vj1*cos(pv1)-uj1) Vy2 = uu0*(Vj2*cos(pv2)-uj2) endif if ( x<=18.0 ) then do l = 1 , 2 vl = l/3.0_wp vil = 1.0_wp r = 1.0_wp do k = 1 , 40 r = 0.25d0*r*x2/(k*(k+vl)) vil = vil + r if ( abs(r)<1.0d-15 ) exit enddo a0 = (0.5_wp*x)**vl if ( l==1 ) Vi1 = a0/gp1*vil if ( l==2 ) Vi2 = a0/gp2*vil enddo else c0 = exp(x)/sqrt(2.0_wp*pi*x) do l = 1 , 2 vv = vv0*l*l vsl = 1.0_wp r = 1.0_wp do k = 1 , k0 r = -0.125d0*r*(vv-(2.0_wp*k-1.0_wp)**2.0)/(k*x) vsl = vsl + r enddo if ( l==1 ) Vi1 = c0*vsl if ( l==2 ) Vi2 = c0*vsl enddo endif if ( x<=9.0_wp ) then gn = 0.0_wp do l = 1 , 2 vl = l/3.0_wp if ( l==1 ) gn = gn1 if ( l==2 ) gn = gn2 a0 = (2.0_wp/x)**vl/gn sum = 1.0_wp r = 1.0_wp do k = 1 , 60 r = 0.25d0*r*x2/(k*(k-vl)) sum = sum + r if ( abs(r)<1.0d-15 ) exit enddo if ( l==1 ) Vk1 = 0.5_wp*uu0*pi*(sum*a0-Vi1) if ( l==2 ) Vk2 = 0.5_wp*uu0*pi*(sum*a0-Vi2) enddo else c0 = exp(-x)*sqrt(halfpi/x) do l = 1 , 2 vv = vv0*l*l sum = 1.0_wp r = 1.0_wp do k = 1 , k0 r = 0.125d0*r*(vv-(2.0*k-1.0)**2.0)/(k*x) sum = sum + r enddo if ( l==1 ) Vk1 = c0*sum if ( l==2 ) Vk2 = c0*sum enddo endif end subroutine cikvb(v,z,Vm,Cbi,Cdi,Cbk,Cdk) ! ! =========================================================== ! Purpose: Compute the modified Bessel functions Iv(z), Kv(z) ! and their derivatives for an arbitrary order and ! complex argument ! Input : z --- Complex argument z ! v --- Real order of Iv(z) and Kv(z) ! ( v =n+v0, n = 0,1,2,..., 0 ≤ v0 < 1 ) ! Output: CBI(n) --- In+v0(z) ! CDI(n) --- In+v0'(z) ! CBK(n) --- Kn+v0(z) ! CDK(n) --- Kn+v0'(z) ! VM --- Highest order computed ! Routines called: ! (1) GAMMA2 for computing the gamma function ! (2) MSTA1 and MSTA2 for computing the starting ! point for backward recurrence ! =========================================================== ! implicit none real(wp) a0 , gan , gap , piv , v , v0 , v0n , v0p , & & Vm , vt , w0 complex(wp) ca , ca1 , ca2 , cb , Cbi , cbi0 , Cbk , cbk0 , Cdi , & & Cdk , cf , cf1 , cf2 , ci , ci0 , ckk , cp , cr , cr1 ,& & cr2 complex(wp) cs , csu , ct , cvk , z , z1 , z2 integer k , k0 , m , n dimension Cbi(0:*) , Cdi(0:*) , Cbk(0:*) , Cdk(0:*) z1 = z z2 = z*z a0 = abs(z) ci = (0.0_wp,1.0_wp) n = int(v) v0 = v - n piv = pi*v0 vt = 4.0_wp*v0*v0 if ( n==0 ) n = 1 if ( a0<1.0d-100 ) then do k = 0 , n Cbi(k) = 0.0_wp Cdi(k) = 0.0_wp Cbk(k) = -1.0e+300_wp Cdk(k) = 1.0e+300_wp enddo if ( v0==0.0 ) then Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) endif Vm = v return endif k0 = 14 if ( a0>=35.0 ) k0 = 10 if ( a0>=50.0 ) k0 = 8 if ( real(z,wp)<0.0 ) z1 = -z if ( a0<18.0 ) then if ( v0==0.0 ) then ca1 = (1.0_wp,0.0_wp) else v0p = 1.0_wp + v0 call gamma2(v0p,gap) ca1 = (0.5_wp*z1)**v0/gap endif ci0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25d0*cr*z2/(k*(k+v0)) ci0 = ci0 + cr if ( abs(cr/ci0)<1.0d-15 ) exit enddo cbi0 = ci0*ca1 else ca = exp(z1)/sqrt(2.0_wp*pi*z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = -0.125d0*cr*(vt-(2.0_wp*k-1.0_wp)**2.0)/(k*z1) cs = cs + cr enddo cbi0 = ca*cs endif m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0d-100,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z1*cf1 + cf2 if ( k<=n ) Cbi(k) = cf cf2 = cf1 cf1 = cf enddo cs = cbi0/cf do k = 0 , n Cbi(k) = cs*Cbi(k) enddo if ( a0>9.0 ) then cb = exp(-z1)*sqrt(halfpi/z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = 0.125d0*cr*(vt-(2.0_wp*k-1.0_wp)**2.0)/(k*z1) cs = cs + cr enddo cbk0 = cb*cs elseif ( v0==0.0 ) then ct = -log(0.5_wp*z1) - 0.5772156649015329d0 cs = (0.0_wp,0.0_wp) w0 = 0.0_wp cr = (1.0_wp,0.0_wp) do k = 1 , 50 w0 = w0 + 1.0_wp/k cr = 0.25d0*cr/(k*k)*z2 cp = cr*(w0+ct) cs = cs + cp if ( k>=10 .and. abs(cp/cs)<1.0d-15 ) exit enddo cbk0 = ct + cs else v0n = 1.0_wp - v0 call gamma2(v0n,gan) ca2 = 1.0_wp/(gan*(0.5_wp*z1)**v0) ca1 = (0.5_wp*z1)**v0/gap csu = ca2 - ca1 cr1 = (1.0_wp,0.0_wp) cr2 = (1.0_wp,0.0_wp) do k = 1 , 50 cr1 = 0.25d0*cr1*z2/(k*(k-v0)) cr2 = 0.25d0*cr2*z2/(k*(k+v0)) cp = ca2*cr1 - ca1*cr2 csu = csu + cp if ( k>=10 .and. abs(cp/csu)<1.0d-15 ) exit enddo cbk0 = halfpi*csu/sin(piv) endif Cbk(0) = cbk0 if ( real(z,wp)<0.0 ) then do k = 0 , n cvk = exp((k+v0)*pi*ci) if ( aimag(z)<0.0_wp ) then Cbk(k) = cvk*Cbk(k) + pi*ci*Cbi(k) Cbi(k) = Cbi(k)/cvk elseif ( aimag(z)>0.0 ) then Cbk(k) = Cbk(k)/cvk - pi*ci*Cbi(k) Cbi(k) = cvk*Cbi(k) endif enddo endif do k = 1 , n ckk = (1.0_wp/z-Cbi(k)*Cbk(k-1))/Cbi(k-1) Cbk(k) = ckk enddo Cdi(0) = v0/z*Cbi(0) + Cbi(1) Cdk(0) = v0/z*Cbk(0) - Cbk(1) do k = 1 , n Cdi(k) = -(k+v0)/z*Cbi(k) + Cbi(k-1) Cdk(k) = -(k+v0)/z*Cbk(k) - Cbk(k-1) enddo Vm = n + v0 end subroutine cikva(v,z,Vm,Cbi,Cdi,Cbk,Cdk) ! ! ============================================================ ! Purpose: Compute the modified Bessel functions Iv(z), Kv(z) ! and their derivatives for an arbitrary order and ! complex argument ! Input : z --- Complex argument ! v --- Real order of Iv(z) and Kv(z) ! ( v = n+v0, n = 0,1,2,…, 0 ≤ v0 < 1 ) ! Output: CBI(n) --- In+v0(z) ! CDI(n) --- In+v0'(z) ! CBK(n) --- Kn+v0(z) ! CDK(n) --- Kn+v0'(z) ! VM --- Highest order computed ! Routines called: ! (1) GAMMA2 for computing the gamma function ! (2) MSTA1 and MSTA2 for computing the starting ! point for backward recurrence ! ============================================================ ! implicit none real(wp) a0 , gan , gap , piv , v , v0 , v0n , v0p , & & Vm , vt , w0 , ws , ws0 complex(wp) ca , ca1 , ca2 , cb , Cbi , cbi0 , Cbk , cbk0 , cbk1 , & & Cdi , Cdk , cf , cf1 , cf2 , cg0 , cg1 , cgk , ci , & & ci0 , cp complex(wp) cr , cr1 , cr2 , cs , csu , ct , cvk , z , z1 , z2 integer k , k0 , m , n dimension Cbi(0:*) , Cdi(0:*) , Cbk(0:*) , Cdk(0:*) ci = (0.0_wp,1.0_wp) a0 = abs(z) z1 = z z2 = z*z n = int(v) v0 = v - n piv = pi*v0 vt = 4.0_wp*v0*v0 if ( n==0 ) n = 1 if ( a0<1.0d-100 ) then do k = 0 , n Cbi(k) = 0.0_wp Cdi(k) = 0.0_wp Cbk(k) = -1.0e+300_wp Cdk(k) = 1.0e+300_wp enddo if ( v0==0.0 ) then Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) endif Vm = v return endif k0 = 14 if ( a0>=35.0 ) k0 = 10 if ( a0>=50.0 ) k0 = 8 if ( real(z,wp)<0.0 ) z1 = -z if ( a0<18.0 ) then if ( v0==0.0 ) then ca1 = (1.0_wp,0.0_wp) else v0p = 1.0_wp + v0 call gamma2(v0p,gap) ca1 = (0.5_wp*z1)**v0/gap endif ci0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25d0*cr*z2/(k*(k+v0)) ci0 = ci0 + cr if ( abs(cr)<abs(ci0)*1.0d-15 ) exit enddo cbi0 = ci0*ca1 else ca = exp(z1)/sqrt(2.0_wp*pi*z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = -0.125d0*cr*(vt-(2.0_wp*k-1.0_wp)**2.0)/(k*z1) cs = cs + cr enddo cbi0 = ca*cs endif m = msta1(a0,200) if ( m<n ) then n = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0d-100,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(v0+k+1.0_wp)/z1*cf1 + cf2 if ( k<=n ) Cbi(k) = cf cf2 = cf1 cf1 = cf enddo cs = cbi0/cf do k = 0 , n Cbi(k) = cs*Cbi(k) enddo if ( a0>9.0 ) then cb = exp(-z1)*sqrt(halfpi/z1) cs = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = 0.125d0*cr*(vt-(2.0_wp*k-1.0_wp)**2.0)/(k*z1) cs = cs + cr enddo cbk0 = cb*cs elseif ( v0==0.0 ) then ct = -log(0.5_wp*z1) - 0.5772156649015329d0 cs = (0.0_wp,0.0_wp) w0 = 0.0_wp cr = (1.0_wp,0.0_wp) do k = 1 , 50 w0 = w0 + 1.0_wp/k cr = 0.25d0*cr/(k*k)*z2 cp = cr*(w0+ct) cs = cs + cp if ( k>=10 .and. abs(cp/cs)<1.0d-15 ) exit enddo cbk0 = ct + cs else v0n = 1.0_wp - v0 call gamma2(v0n,gan) ca2 = 1.0_wp/(gan*(0.5_wp*z1)**v0) ca1 = (0.5_wp*z1)**v0/gap csu = ca2 - ca1 cr1 = (1.0_wp,0.0_wp) cr2 = (1.0_wp,0.0_wp) ws0 = 0.0_wp do k = 1 , 50 cr1 = 0.25d0*cr1*z2/(k*(k-v0)) cr2 = 0.25d0*cr2*z2/(k*(k+v0)) csu = csu + ca2*cr1 - ca1*cr2 ws = abs(csu) if ( k>=10 .and. abs(ws-ws0)/ws<1.0d-15 ) exit ws0 = ws enddo cbk0 = halfpi*csu/sin(piv) endif cbk1 = (1.0_wp/z1-Cbi(1)*cbk0)/Cbi(0) Cbk(0) = cbk0 Cbk(1) = cbk1 cg0 = cbk0 cg1 = cbk1 do k = 2 , n cgk = 2.0_wp*(v0+k-1.0_wp)/z1*cg1 + cg0 Cbk(k) = cgk cg0 = cg1 cg1 = cgk enddo if ( real(z,wp)<0.0 ) then do k = 0 , n cvk = exp((k+v0)*pi*ci) if ( aimag(z)<0.0_wp ) then Cbk(k) = cvk*Cbk(k) + pi*ci*Cbi(k) Cbi(k) = Cbi(k)/cvk elseif ( aimag(z)>0.0 ) then Cbk(k) = Cbk(k)/cvk - pi*ci*Cbi(k) Cbi(k) = cvk*Cbi(k) endif enddo endif Cdi(0) = v0/z*Cbi(0) + Cbi(1) Cdk(0) = v0/z*Cbk(0) - Cbk(1) do k = 1 , n Cdi(k) = -(k+v0)/z*Cbi(k) + Cbi(k-1) Cdk(k) = -(k+v0)/z*Cbk(k) - Cbk(k-1) enddo Vm = n + v0 end subroutine cfc(z,Zf,Zd) ! ! ========================================================= ! Purpose: Compute complex Fresnel integral C(z) and C'(z) ! Input : z --- Argument of C(z) ! Output: ZF --- C(z) ! ZD --- C'(z) ! ========================================================= ! implicit none complex(wp) c , cf , cf0 , cf1 , cg , cr , d , z , z0 , Zd , Zf , & & zp , zp2 real(wp) eps , w0 , wa , wa0 integer k , m eps = 1.0d-14 w0 = abs(z) zp = halfpi*z*z zp2 = zp*zp z0 = (0.0_wp,0.0_wp) if ( z==z0 ) then c = z0 elseif ( w0<=2.5 ) then cr = z c = cr wa0 = 0.0_wp do k = 1 , 80 cr = -0.5_wp*cr*(4.0_wp*k-3.0_wp)/k/(2.0_wp*k-1.0_wp) & & /(4.0_wp*k+1.0_wp)*zp2 c = c + cr wa = abs(c) if ( abs((wa-wa0)/wa)<eps .and. k>10 ) goto 100 wa0 = wa enddo elseif ( w0>2.5 .and. w0<4.5 ) then m = 85 c = z0 cf1 = z0 cf0 = (1.0d-100,0.0_wp) do k = m , 0 , -1 cf = (2.0_wp*k+3.0_wp)*cf0/zp - cf1 if ( k==int(k/2)*2 ) c = c + cf cf1 = cf0 cf0 = cf enddo c = 2.0_wp/(pi*z)*sin(zp)/cf*c else ! See comment at CFS(), use C(z) = iC(-iz) if ( aimag(z)>-real(z,wp) .and. aimag(z)<=real(z,wp) ) then ! right quadrant d = dcmplx(0.5_wp,0.0_wp) elseif ( aimag(z)>real(z,wp) .and. aimag(z)>=-real(z,wp) ) then ! upper quadrant d = dcmplx(0.0_wp,0.5_wp) elseif ( aimag(z)<-real(z,wp) .and. aimag(z)>=real(z,wp) ) then ! left quadrant d = dcmplx(-0.5_wp,0.0_wp) else ! lower quadrant d = dcmplx(0.0_wp,-0.5_wp) endif cr = (1.0_wp,0.0_wp) cf = (1.0_wp,0.0_wp) do k = 1 , 20 cr = -0.25_wp*cr*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/zp2 cf = cf + cr enddo cr = 1.0_wp/(pi*z*z) cg = cr do k = 1 , 12 cr = -0.25_wp*cr*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/zp2 cg = cg + cr enddo c = d + (cf*sin(zp)-cg*cos(zp))/(pi*z) endif 100 Zf = c Zd = cos(halfpi*z*z) end subroutine fcs(x,c,s) ! ! ================================================= ! Purpose: Compute Fresnel integrals C(x) and S(x) ! Input : x --- Argument of C(x) and S(x) ! Output: C --- C(x) ! S --- S(x) ! ================================================= ! implicit none real(wp) c , eps , f , f0 , f1 , g , px , q , r , s ,& & su , t , t0 , t2 , x , xa integer k , m eps = 1.0d-15 xa = abs(x) px = pi*xa t = .5d0*px*xa t2 = t*t if ( xa==0.0 ) then c = 0.0_wp s = 0.0_wp elseif ( xa<2.5d0 ) then r = xa c = r do k = 1 , 50 r = -0.5_wp*r*(4.0_wp*k-3.0_wp)/k/(2.0_wp*k-1.0_wp) & & /(4.0_wp*k+1.0_wp)*t2 c = c + r if ( abs(r)<abs(c)*eps ) exit enddo s = xa*t/3.0_wp r = s do k = 1 , 50 r = -0.5_wp*r*(4.0_wp*k-1.0_wp)/k/(2.0_wp*k+1.0_wp) & & /(4.0_wp*k+3.0_wp)*t2 s = s + r if ( abs(r)<abs(s)*eps ) goto 100 enddo elseif ( xa<4.5d0 ) then m = int(42.0+1.75*t) su = 0.0_wp c = 0.0_wp s = 0.0_wp f1 = 0.0_wp f0 = 1.0d-100 do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f0/t - f1 if ( k==int(k/2)*2 ) then c = c + f else s = s + f endif su = su + (2.0_wp*k+1.0_wp)*f*f f1 = f0 f0 = f enddo q = sqrt(su) c = c*xa/q s = s*xa/q else r = 1.0_wp f = 1.0_wp do k = 1 , 20 r = -0.25_wp*r*(4.0_wp*k-1.0_wp)*(4.0_wp*k-3.0_wp)/t2 f = f + r enddo r = 1.0_wp/(px*xa) g = r do k = 1 , 12 r = -0.25_wp*r*(4.0_wp*k+1.0_wp)*(4.0_wp*k-1.0_wp)/t2 g = g + r enddo t0 = t - int(t/(2.0_wp*pi))*2.0_wp*pi c = .5d0 + (f*sin(t0)-g*cos(t0))/px s = .5d0 - (f*cos(t0)+g*sin(t0))/px endif 100 if ( x<0.0_wp ) then c = -c s = -s endif end subroutine rctj(n,x,Nm,Rj,Dj) ! ! ======================================================== ! Purpose: Compute Riccati-Bessel functions of the first ! kind and their derivatives ! Input: x --- Argument of Riccati-Bessel function ! n --- Order of jn(x) ( n = 0,1,2,... ) ! Output: RJ(n) --- x·jn(x) ! DJ(n) --- [x·jn(x)]' ! NM --- Highest order computed ! Routines called: ! MSTA1 and MSTA2 for computing the starting ! point for backward recurrence ! ======================================================== ! implicit none real(wp) cs , Dj , f , f0 , f1 , Rj , rj0 , rj1 , x integer k , m , n , Nm dimension Rj(0:n) , Dj(0:n) Nm = n if ( abs(x)<1.0d-100 ) then do k = 0 , n Rj(k) = 0.0_wp Dj(k) = 0.0_wp enddo Dj(0) = 1.0_wp return endif Rj(0) = sin(x) Rj(1) = Rj(0)/x - cos(x) rj0 = Rj(0) rj1 = Rj(1) cs = 0.0_wp f = 0.0_wp if ( n>=2 ) then m = msta1(x,200) if ( m<n ) then Nm = m else m = msta2(x,n,15) endif f0 = 0.0_wp f1 = 1.0d-100 do k = m , 0 , -1 f = (2.0_wp*k+3.0_wp)*f1/x - f0 if ( k<=Nm ) Rj(k) = f f0 = f1 f1 = f enddo if ( abs(rj0)>abs(rj1) ) cs = rj0/f if ( abs(rj0)<=abs(rj1) ) cs = rj1/f0 do k = 0 , Nm Rj(k) = cs*Rj(k) enddo endif Dj(0) = cos(x) do k = 1 , Nm Dj(k) = -k*Rj(k)/x + Rj(k-1) enddo end subroutine herzo(n,x,w) ! ! ======================================================== ! Purpose : Compute the zeros of Hermite polynomial Ln(x) ! in the interval [-∞,∞], and the corresponding ! weighting coefficients for Gauss-Hermite ! integration ! Input : n --- Order of the Hermite polynomial ! X(n) --- Zeros of the Hermite polynomial ! W(n) --- Corresponding weighting coefficients ! ======================================================== ! implicit none real(wp) f0 , f1 , fd , gd , hd , hf , hn , p , q , r , & & r1 , r2 , w , wp_ , x , z , z0 , zl integer i , it , j , k , n , nr dimension x(n) , w(n) hn = 1.0_wp/n zl = -1.1611d0 + 1.46d0*n**0.5 z = 0.0_wp hf = 0.0_wp hd = 0.0_wp do nr = 1 , n/2 if ( nr==1 ) z = zl if ( nr/=1 ) z = z - hn*(n/2+1-nr) it = 0 50 it = it + 1 z0 = z f0 = 1.0_wp f1 = 2.0_wp*z do k = 2 , n hf = 2.0_wp*z*f1 - 2.0_wp*(k-1.0_wp)*f0 hd = 2.0_wp*k*f1 f0 = f1 f1 = hf enddo p = 1.0_wp do i = 1 , nr - 1 p = p*(z-x(i)) enddo fd = hf/p q = 0.0_wp do i = 1 , nr - 1 wp_ = 1.0_wp do j = 1 , nr - 1 if ( j/=i ) wp_ = wp_*(z-x(j)) enddo q = q + wp_ enddo gd = (hd-q*fd)/p z = z - fd/gd if ( it<=40 .and. abs((z-z0)/z)>1.0d-15 ) goto 50 x(nr) = z x(n+1-nr) = -z r = 1.0_wp do k = 1 , n r = 2.0_wp*r*k enddo w(nr) = 3.544907701811d0*r/(hd*hd) w(n+1-nr) = w(nr) enddo if ( n/=2*int(n/2) ) then r1 = 1.0_wp r2 = 1.0_wp do j = 1 , n r1 = 2.0_wp*r1*j if ( j>=(n+1)/2 ) r2 = r2*j enddo w(n/2+1) = 0.88622692545276d0*r1/(r2*r2) x(n/2+1) = 0.0_wp endif end subroutine jy01b(x,Bj0,Dj0,Bj1,Dj1,By0,Dy0,By1,Dy1) ! ! ======================================================= ! Purpose: Compute Bessel functions J0(x), J1(x), Y0(x), ! Y1(x), and their derivatives ! Input : x --- Argument of Jn(x) & Yn(x) ( x ≥ 0 ) ! Output: BJ0 --- J0(x) ! DJ0 --- J0'(x) ! BJ1 --- J1(x) ! DJ1 --- J1'(x) ! BY0 --- Y0(x) ! DY0 --- Y0'(x) ! BY1 --- Y1(x) ! DY1 --- Y1'(x) ! ======================================================= ! implicit none real(wp) a0 , Bj0 , Bj1 , By0 , By1 , Dj0 , Dj1 , Dy0 , & & Dy1 , p0 , p1 , q0 , q1 , t , t2 , ta0 , & & ta1 , x if ( x==0.0_wp ) then Bj0 = 1.0_wp Bj1 = 0.0_wp Dj0 = 0.0_wp Dj1 = 0.5_wp By0 = -1.0e+300_wp By1 = -1.0e+300_wp Dy0 = 1.0e+300_wp Dy1 = 1.0e+300_wp return elseif ( x<=4.0_wp ) then t = x/4.0_wp t2 = t*t Bj0 = ((((((-.5014415d-3*t2+.76771853d-2)*t2-.0709253492d0)*t2+& & .4443584263d0)*t2-1.7777560599d0)*t2+3.9999973021d0) & & *t2-3.9999998721d0)*t2 + 1.0_wp Bj1 = t* & & (((((((-.1289769d-3*t2+.22069155d-2)*t2-.0236616773d0)*t2& & +.1777582922d0)*t2-.8888839649d0)*t2+2.6666660544d0) & & *t2-3.9999999710d0)*t2+1.9999999998d0) By0 = (((((((-.567433d-4*t2+.859977d-3)*t2-.94855882d-2)*t2+ & & .0772975809d0)*t2-.4261737419d0)*t2+1.4216421221d0) & & *t2-2.3498519931d0)*t2+1.0766115157d0)*t2 + .3674669052d0 By0 = 2.0_wp/pi*log(x/2.0_wp)*Bj0 + By0 By1 = ((((((((.6535773d-3*t2-.0108175626d0)*t2+.107657606d0)*t2& & -.7268945577d0)*t2+3.1261399273d0)*t2-7.3980241381d0) & & *t2+6.8529236342d0)*t2+.3932562018d0)*t2-.6366197726d0)/x By1 = 2.0_wp/pi*log(x/2.0_wp)*Bj1 + By1 else t = 4.0_wp/x t2 = t*t a0 = sqrt(2.0_wp/(pi*x)) p0 = ((((-.9285d-5*t2+.43506d-4)*t2-.122226d-3)*t2+.434725d-3) & & *t2-.4394275d-2)*t2 + .999999997d0 q0 = t*(((((.8099d-5*t2-.35614d-4)*t2+.85844d-4)*t2-.218024d-3)& & *t2+.1144106d-2)*t2-.031249995d0) ta0 = x - .25d0*pi Bj0 = a0*(p0*cos(ta0)-q0*sin(ta0)) By0 = a0*(p0*sin(ta0)+q0*cos(ta0)) p1 = ((((.10632d-4*t2-.50363d-4)*t2+.145575d-3)*t2-.559487d-3) & & *t2+.7323931d-2)*t2 + 1.000000004d0 q1 = t* & & (((((-.9173d-5*t2+.40658d-4)*t2-.99941d-4)*t2+.266891d-3) & & *t2-.1601836d-2)*t2+.093749994d0) ta1 = x - .75d0*pi Bj1 = a0*(p1*cos(ta1)-q1*sin(ta1)) By1 = a0*(p1*sin(ta1)+q1*cos(ta1)) endif Dj0 = -Bj1 Dj1 = Bj0 - Bj1/x Dy0 = -By1 Dy1 = By0 - By1/x end subroutine enxb(n,x,En) ! ! =============================================== ! Purpose: Compute exponential integral En(x) ! Input : x --- Argument of En(x) ! n --- Order of En(x) (n = 0,1,2,...) ! Output: EN(n) --- En(x) ! =============================================== ! implicit none real(wp) En , ens , ps , r , rp , s , s0 , t , t0 , x integer j , k , l , m , n dimension En(0:n) if ( x==0.0 ) then En(0) = 1.0e+300_wp En(1) = 1.0e+300_wp do k = 2 , n En(k) = 1.0_wp/(k-1.0) enddo return elseif ( x<=1.0 ) then En(0) = exp(-x)/x s0 = 0.0_wp do l = 1 , n rp = 1.0_wp do j = 1 , l - 1 rp = -rp*x/j enddo ps = -0.5772156649015328d0 do m = 1 , l - 1 ps = ps + 1.0_wp/m enddo ens = rp*(-log(x)+ps) s = 0.0_wp do m = 0 , 20 if ( m/=l-1 ) then r = 1.0_wp do j = 1 , m r = -r*x/j enddo s = s + r/(m-l+1.0_wp) if ( abs(s-s0)<abs(s)*1.0d-15 ) exit s0 = s endif enddo En(l) = ens - s enddo else En(0) = exp(-x)/x m = 15 + int(100.0/x) do l = 1 , n t0 = 0.0_wp do k = m , 1 , -1 t0 = (l+k-1.0_wp)/(1.0_wp+k/(x+t0)) enddo t = 1.0_wp/(x+t0) En(l) = exp(-x)*t enddo endif end subroutine sphk(n,x,Nm,Sk,Dk) ! ! ===================================================== ! Purpose: Compute modified spherical Bessel functions ! of the second kind, kn(x) and kn'(x) ! Input : x --- Argument of kn(x) ( x ≥ 0 ) ! n --- Order of kn(x) ( n = 0,1,2,... ) ! Output: SK(n) --- kn(x) ! DK(n) --- kn'(x) ! NM --- Highest order computed ! ===================================================== ! implicit none real(wp) Dk , f , f0 , f1 , Sk , x integer k , n , Nm dimension Sk(0:n) , Dk(0:n) Nm = n if ( x<1.0d-60 ) then do k = 0 , n Sk(k) = 1.0e+300_wp Dk(k) = -1.0e+300_wp enddo return endif Sk(0) = halfpi/x*exp(-x) Sk(1) = Sk(0)*(1.0_wp+1.0_wp/x) f0 = Sk(0) f1 = Sk(1) do k = 2 , n f = (2.0_wp*k-1.0_wp)*f1/x + f0 Sk(k) = f if ( abs(f)>1.0e+300_wp ) exit f0 = f1 f1 = f enddo Nm = k - 1 Dk(0) = -Sk(1) do k = 1 , Nm Dk(k) = -Sk(k-1) - (k+1.0_wp)/x*Sk(k) enddo end subroutine enxa(n,x,En) ! ! ============================================ ! Purpose: Compute exponential integral En(x) ! Input : x --- Argument of En(x) ( x ≤ 20 ) ! n --- Order of En(x) ! Output: EN(n) --- En(x) ! Routine called: E1XB for computing E1(x) ! ============================================ ! implicit none real(wp) e1 , ek , En , x integer k , n dimension En(0:n) En(0) = exp(-x)/x call e1xb(x,e1) En(1) = e1 do k = 2 , n ek = (exp(-x)-x*e1)/(k-1.0_wp) En(k) = ek e1 = ek enddo end subroutine gaih(x,Ga) ! ! ===================================================== ! Purpose: Compute gamma function Г(x) ! Input : x --- Argument of Г(x), x = n/2, n=1,2,… ! Output: GA --- Г(x) ! ===================================================== ! implicit none real(wp) Ga , x integer k , m , m1 if ( x==int(x) .and. x>0.0 ) then Ga = 1.0_wp m1 = int(x-1.0) do k = 2 , m1 Ga = Ga*k enddo elseif ( x+.5d0==int(x+.5d0) .and. x>0.0 ) then m = int(x) Ga = sqrtpi do k = 1 , m Ga = 0.5_wp*Ga*(2.0_wp*k-1.0_wp) enddo endif end subroutine pbvv(v,x,Vv,Vp,Pvf,Pvd) ! ! =================================================== ! Purpose: Compute parabolic cylinder functions Vv(x) ! and their derivatives ! Input: x --- Argument of Vv(x) ! v --- Order of Vv(x) ! Output: VV(na) --- Vv(x) ! VP(na) --- Vv'(x) ! ( na = |n|, v = n+v0, |v0| < 1 ! n = 0,±1,±2,… ) ! PVF --- Vv(x) ! PVD --- Vv'(x) ! Routines called: ! (1) VVSA for computing Vv(x) for small |x| ! (2) VVLA for computing Vv(x) for large |x| ! =================================================== ! implicit none real(wp) f , f0 , f1 , pv0 , Pvd , Pvf , q2p , qe , & & s0 , v , v0 , v1 , v2 , vh , Vp , Vv , x , xa integer ja , k , kv , l , m , na , nv dimension Vv(0:*) , Vp(0:*) xa = abs(x) vh = v v = v + sign(1.0_wp,v) nv = int(v) v0 = v - nv na = abs(nv) qe = exp(0.25d0*x*x) q2p = sqrt(2.0_wp/pi) ja = 0 if ( na>=1 ) ja = 1 f = 0.0_wp if ( v<=0.0 ) then if ( v0==0.0 ) then if ( xa<=7.5 ) call vvsa(v0,x,pv0) if ( xa>7.5 ) call vvla(v0,x,pv0) f0 = q2p*qe f1 = x*f0 Vv(0) = pv0 Vv(1) = f0 Vv(2) = f1 else do l = 0 , ja v1 = v0 - l if ( xa<=7.5 ) call vvsa(v1,x,f1) if ( xa>7.5 ) call vvla(v1,x,f1) if ( l==0 ) f0 = f1 enddo Vv(0) = f0 Vv(1) = f1 endif kv = 2 if ( v0==0.0 ) kv = 3 do k = kv , na f = x*f1 + (k-v0-2.0_wp)*f0 Vv(k) = f f0 = f1 f1 = f enddo elseif ( x>=0.0 .and. x<=7.5d0 ) then v2 = v if ( v2<1.0 ) v2 = v2 + 1.0_wp call vvsa(v2,x,f1) v1 = v2 - 1.0_wp kv = int(v2) call vvsa(v1,x,f0) Vv(kv) = f1 Vv(kv-1) = f0 do k = kv - 2 , 0 , -1 f = x*f0 - (k+v0+2.0_wp)*f1 if ( k<=na ) Vv(k) = f f1 = f0 f0 = f enddo elseif ( x>7.5d0 ) then call vvla(v0,x,pv0) m = 100 + abs(na) Vv(1) = pv0 f1 = 0.0_wp f0 = 1.0d-40 do k = m , 0 , -1 f = x*f0 - (k+v0+2.0_wp)*f1 if ( k<=na ) Vv(k) = f f1 = f0 f0 = f enddo s0 = pv0/f do k = 0 , na Vv(k) = s0*Vv(k) enddo else if ( xa<=7.5d0 ) then call vvsa(v0,x,f0) v1 = v0 + 1.0 call vvsa(v1,x,f1) else call vvla(v0,x,f0) v1 = v0 + 1.0_wp call vvla(v1,x,f1) endif Vv(0) = f0 Vv(1) = f1 do k = 2 , na f = (x*f1-f0)/(k+v0) Vv(k) = f f0 = f1 f1 = f enddo endif do k = 0 , na - 1 v1 = v0 + k if ( v>=0.0_wp ) then Vp(k) = 0.5_wp*x*Vv(k) - (v1+1.0_wp)*Vv(k+1) else Vp(k) = -0.5_wp*x*Vv(k) + Vv(k+1) endif enddo Pvf = Vv(na-1) Pvd = Vp(na-1) v = vh end subroutine clqmn(Mm,m,n,x,y,Cqm,Cqd) ! ! ======================================================= ! Purpose: Compute the associated Legendre functions of ! the second kind, Qmn(z) and Qmn'(z), for a ! complex argument ! Input : x --- Real part of z ! y --- Imaginary part of z ! m --- Order of Qmn(z) ( m = 0,1,2,… ) ! n --- Degree of Qmn(z) ( n = 0,1,2,… ) ! mm --- Physical dimension of CQM and CQD ! Output: CQM(m,n) --- Qmn(z) ! CQD(m,n) --- Qmn'(z) ! ======================================================= ! implicit none complex(wp) cq0 , cq1 , cq10 , Cqd , cqf , cqf0 , cqf1 , cqf2 , & & Cqm , z , zq , zs integer i , j , k , km , ls , m , Mm , n real(wp) x , xc , y dimension Cqm(0:Mm,0:n) , Cqd(0:Mm,0:n) z = dcmplx(x,y) if ( abs(x)==1.0_wp .and. y==0.0_wp ) then do i = 0 , m do j = 0 , n Cqm(i,j) = (1.0e+300_wp,0.0_wp) Cqd(i,j) = (1.0e+300_wp,0.0_wp) enddo enddo return endif xc = abs(z) ls = 0 if ( aimag(z)==0.0_wp .or. xc<1.0_wp ) ls = 1 if ( xc>1.0_wp ) ls = -1 zq = sqrt(ls*(1.0_wp-z*z)) zs = ls*(1.0_wp-z*z) cq0 = 0.5_wp*log(ls*(1.0_wp+z)/(1.0_wp-z)) if ( xc<1.0001_wp ) then Cqm(0,0) = cq0 Cqm(0,1) = z*cq0 - 1.0_wp Cqm(1,0) = -1.0_wp/zq Cqm(1,1) = -zq*(cq0+z/(1.0_wp-z*z)) do i = 0 , 1 do j = 2 , n Cqm(i,j) = ((2.0_wp*j-1.0_wp)*z*Cqm(i,j-1)-(j+i-1.0_wp) & & *Cqm(i,j-2))/(j-i) enddo enddo do j = 0 , n do i = 2 , m Cqm(i,j) = -2.0_wp*(i-1.0_wp)*z/zq*Cqm(i-1,j) & & - ls*(j+i-1.0_wp)*(j-i+2.0_wp)*Cqm(i-2,j) enddo enddo else if ( xc>1.1 ) then km = 40 + m + n else km = (40+m+n)*int(-1.0-1.8*log(xc-1.0)) endif cqf2 = (0.0_wp,0.0_wp) cqf1 = (1.0_wp,0.0_wp) do k = km , 0 , -1 cqf0 = ((2*k+3.0_wp)*z*cqf1-(k+2.0_wp)*cqf2)/(k+1.0_wp) if ( k<=n ) Cqm(0,k) = cqf0 cqf2 = cqf1 cqf1 = cqf0 enddo do k = 0 , n Cqm(0,k) = cq0*Cqm(0,k)/cqf0 enddo cqf2 = 0.0_wp cqf1 = 1.0_wp do k = km , 0 , -1 cqf0 = ((2*k+3.0_wp)*z*cqf1-(k+1.0_wp)*cqf2)/(k+2.0_wp) if ( k<=n ) Cqm(1,k) = cqf0 cqf2 = cqf1 cqf1 = cqf0 enddo cq10 = -1.0_wp/zq do k = 0 , n Cqm(1,k) = cq10*Cqm(1,k)/cqf0 enddo do j = 0 , n cq0 = Cqm(0,j) cq1 = Cqm(1,j) do i = 0 , m - 2 cqf = -2.0_wp*(i+1)*z/zq*cq1 + (j-i)*(j+i+1.0_wp)*cq0 Cqm(i+2,j) = cqf cq0 = cq1 cq1 = cqf enddo enddo endif Cqd(0,0) = ls/zs do j = 1 , n Cqd(0,j) = ls*j*(Cqm(0,j-1)-z*Cqm(0,j))/zs enddo do j = 0 , n do i = 1 , m Cqd(i,j) = ls*i*z/zs*Cqm(i,j) + (i+j)*(j-i+1.0_wp) & & /zq*Cqm(i-1,j) enddo enddo end subroutine segv(m,n,c,Kd,Cv,Eg) ! ! ========================================================= ! Purpose: Compute the characteristic values of spheroidal ! wave functions ! Input : m --- Mode parameter ! n --- Mode parameter ! c --- Spheroidal parameter ! KD --- Function code ! KD=1 for Prolate; KD=-1 for Oblate ! Output: CV --- Characteristic value for given m, n and c ! EG(L) --- Characteristic value for mode m and n' ! ( L = n' - m + 1 ) ! ========================================================= ! implicit none real(wp) a , b , c , cs , Cv , cv0 , d , d2k , dk0 , dk1 ,& & dk2 , e , Eg , f , g , h , s , t , t1 , x1 real(wp) xa , xb integer i , icm , j , k , k1 , Kd , l , m , n , nm , nm1 dimension b(100) , h(100) , d(300) , e(300) , f(300) , cv0(100) , & & a(300) , g(300) , Eg(200) if ( c<1.0d-10 ) then do i = 1 , n - m + 1 Eg(i) = (i+m)*(i+m-1.0_wp) enddo goto 100 endif icm = (n-m+2)/2 nm = 10 + int(0.5*(n-m)+c) cs = c*c*Kd k = 0 do l = 0 , 1 do i = 1 , nm if ( l==0 ) k = 2*(i-1) if ( l==1 ) k = 2*i - 1 dk0 = m + k dk1 = m + k + 1 dk2 = 2*(m+k) d2k = 2*m + k a(i) = (d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs d(i) = dk0*dk1 + (2.0*dk0*dk1-2.0*m*m-1.0) & & /((dk2-1.0)*(dk2+3.0))*cs g(i) = k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs enddo do k = 2 , nm e(k) = sqrt(a(k-1)*g(k)) f(k) = e(k)*e(k) enddo f(1) = 0.0_wp e(1) = 0.0_wp xa = d(nm) + abs(e(nm)) xb = d(nm) - abs(e(nm)) nm1 = nm - 1 do i = 1 , nm1 t = abs(e(i)) + abs(e(i+1)) t1 = d(i) + t if ( xa<t1 ) xa = t1 t1 = d(i) - t if ( t1<xb ) xb = t1 enddo do i = 1 , icm b(i) = xa h(i) = xb enddo do k = 1 , icm do k1 = k , icm if ( b(k1)<b(k) ) then b(k) = b(k1) exit endif enddo if ( k/=1 ) then if ( h(k)<h(k-1) ) h(k) = h(k-1) endif 40 x1 = (b(k)+h(k))/2.0_wp cv0(k) = x1 if ( abs((b(k)-h(k))/x1)<1.0d-14 ) then cv0(k) = x1 if ( l==0 ) Eg(2*k-1) = cv0(k) if ( l==1 ) Eg(2*k) = cv0(k) else j = 0 s = 1.0_wp do i = 1 , nm if ( s==0.0_wp ) s = s + 1.0d-30 t = f(i)/s s = d(i) - t - x1 if ( s<0.0_wp ) j = j + 1 enddo if ( j<k ) then h(k) = x1 else b(k) = x1 if ( j>=icm ) then b(icm) = x1 else if ( h(j+1)<x1 ) h(j+1) = x1 if ( x1<b(j) ) b(j) = x1 endif endif goto 40 endif enddo enddo 100 Cv = Eg(n-m+1) end subroutine ciknb(n,z,Nm,Cbi,Cdi,Cbk,Cdk) ! ! ============================================================ ! Purpose: Compute modified Bessel functions In(z) and Kn(z), ! and their derivatives for a complex argument ! Input: z --- Complex argument ! n --- Order of In(z) and Kn(z) ! Output: CBI(n) --- In(z) ! CDI(n) --- In'(z) ! CBK(n) --- Kn(z) ! CDK(n) --- Kn'(z) ! NM --- Highest order computed ! Routones called: ! MSTA1 and MSTA2 to compute the starting point for ! backward recurrence ! =========================================================== ! implicit none real(wp) a0 , el , fac , vt complex(wp) ca0 , Cbi , Cbk , cbkl , cbs , Cdi , Cdk , cf , cf0 , & & cf1 , cg , cg0 , cg1 , ci , cr , cs0 , csk0 , z , z1 integer k , k0 , l , m , n , Nm dimension Cbi(0:n) , Cdi(0:n) , Cbk(0:n) , Cdk(0:n) el = 0.57721566490153d0 a0 = abs(z) Nm = n if ( a0<1.0d-100 ) then do k = 0 , n Cbi(k) = (0.0_wp,0.0_wp) Cbk(k) = (1.0e+300_wp,0.0_wp) Cdi(k) = (0.0_wp,0.0_wp) Cdk(k) = -(1.0e+300_wp,0.0_wp) enddo Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) return endif z1 = z ci = (0.0_wp,1.0_wp) if ( real(z,wp)<0.0 ) z1 = -z if ( n==0 ) Nm = 1 m = msta1(a0,200) if ( m<Nm ) then Nm = m else m = msta2(a0,Nm,15) endif cbs = 0.0_wp csk0 = 0.0_wp cf0 = 0.0_wp cf1 = 1.0d-100 do k = m , 0 , -1 cf = 2.0_wp*(k+1.0_wp)*cf1/z1 + cf0 if ( k<=Nm ) Cbi(k) = cf if ( k/=0 .and. k==2*int(k/2) ) csk0 = csk0 + 4.0_wp*cf/k cbs = cbs + 2.0_wp*cf cf0 = cf1 cf1 = cf enddo cs0 = exp(z1)/(cbs-cf) do k = 0 , Nm Cbi(k) = cs0*Cbi(k) enddo if ( a0<=9.0 ) then Cbk(0) = -(log(0.5_wp*z1)+el)*Cbi(0) + cs0*csk0 Cbk(1) = (1.0_wp/z1-Cbi(1)*Cbk(0))/Cbi(0) else ca0 = sqrt(pi/(2.0_wp*z1))*exp(-z1) k0 = 16 if ( a0>=25.0 ) k0 = 10 if ( a0>=80.0 ) k0 = 8 if ( a0>=200.0 ) k0 = 6 do l = 0 , 1 cbkl = 1.0_wp vt = 4.0_wp*l cr = (1.0_wp,0.0_wp) do k = 1 , k0 cr = 0.125d0*cr*(vt-(2.0*k-1.0)**2)/(k*z1) cbkl = cbkl + cr enddo Cbk(l) = ca0*cbkl enddo endif cg0 = Cbk(0) cg1 = Cbk(1) do k = 2 , Nm cg = 2.0_wp*(k-1.0_wp)/z1*cg1 + cg0 Cbk(k) = cg cg0 = cg1 cg1 = cg enddo if ( real(z,wp)<0.0 ) then fac = 1.0_wp do k = 0 , Nm if ( aimag(z)<0.0 ) then Cbk(k) = fac*Cbk(k) + ci*pi*Cbi(k) else Cbk(k) = fac*Cbk(k) - ci*pi*Cbi(k) endif Cbi(k) = fac*Cbi(k) fac = -fac enddo endif Cdi(0) = Cbi(1) Cdk(0) = -Cbk(1) do k = 1 , Nm Cdi(k) = Cbi(k-1) - k/z*Cbi(k) Cdk(k) = -Cbk(k-1) - k/z*Cbk(k) enddo end subroutine cikna(n,z,Nm,Cbi,Cdi,Cbk,Cdk) ! ! ======================================================== ! Purpose: Compute modified Bessel functions In(z), Kn(x) ! and their derivatives for a complex argument ! Input : z --- Complex argument of In(z) and Kn(z) ! n --- Order of In(z) and Kn(z) ! Output: CBI(n) --- In(z) ! CDI(n) --- In'(z) ! CBK(n) --- Kn(z) ! CDK(n) --- Kn'(z) ! NM --- Highest order computed ! Routines called: ! (1) CIK01 to compute I0(z), I1(z) K0(z) & K1(z) ! (2) MSTA1 and MSTA2 to compute the starting ! point for backward recurrence ! ======================================================== ! implicit none real(wp) a0 complex(wp) Cbi , cbi0 , cbi1 , Cbk , cbk0 , cbk1 , Cdi , cdi0 , & & cdi1 , Cdk , cdk0 , cdk1 , cf , cf1 , cf2 , ckk , cs , & & z integer k , m , n , Nm dimension Cbi(0:n) , Cdi(0:n) , Cbk(0:n) , Cdk(0:n) a0 = abs(z) Nm = n if ( a0<1.0d-100 ) then do k = 0 , n Cbi(k) = (0.0_wp,0.0_wp) Cdi(k) = (0.0_wp,0.0_wp) Cbk(k) = -(1.0e+300_wp,0.0_wp) Cdk(k) = (1.0e+300_wp,0.0_wp) enddo Cbi(0) = (1.0_wp,0.0_wp) Cdi(1) = (0.5_wp,0.0_wp) return endif call cik01(z,cbi0,cdi0,cbi1,cdi1,cbk0,cdk0,cbk1,cdk1) Cbi(0) = cbi0 Cbi(1) = cbi1 Cbk(0) = cbk0 Cbk(1) = cbk1 Cdi(0) = cdi0 Cdi(1) = cdi1 Cdk(0) = cdk0 Cdk(1) = cdk1 if ( n<=1 ) return m = msta1(a0,200) if ( m<n ) then Nm = m else m = msta2(a0,n,15) endif cf2 = (0.0_wp,0.0_wp) cf1 = (1.0d-100,0.0_wp) do k = m , 0 , -1 cf = 2.0_wp*(k+1.0_wp)/z*cf1 + cf2 if ( k<=Nm ) Cbi(k) = cf cf2 = cf1 cf1 = cf enddo cs = cbi0/cf do k = 0 , Nm Cbi(k) = cs*Cbi(k) enddo do k = 2 , Nm if ( abs(Cbi(k-1))>abs(Cbi(k-2)) ) then ckk = (1.0_wp/z-Cbi(k)*Cbk(k-1))/Cbi(k-1) else ckk = (Cbi(k)*Cbk(k-2)+2.0_wp*(k-1.0_wp)/(z*z))/Cbi(k-2) endif Cbk(k) = ckk enddo do k = 2 , Nm Cdi(k) = Cbi(k-1) - k/z*Cbi(k) Cdk(k) = -Cbk(k-1) - k/z*Cbk(k) enddo end subroutine mtu12(Kf,Kc,m,q,x,F1r,D1r,F2r,D2r) ! ! ============================================================== ! Purpose: Compute modified Mathieu functions of the first and ! second kinds, Mcm(1)(2)(x,q) and Msm(1)(2)(x,q), ! and their derivatives ! Input: KF --- Function code ! KF=1 for computing Mcm(x,q) ! KF=2 for computing Msm(x,q) ! KC --- Function Code ! KC=1 for computing the first kind ! KC=2 for computing the second kind ! or Msm(2)(x,q) and Msm(2)'(x,q) ! KC=3 for computing both the first ! and second kinds ! m --- Order of Mathieu functions ! q --- Parameter of Mathieu functions ( q ≥ 0 ) ! x --- Argument of Mathieu functions ! Output: F1R --- Mcm(1)(x,q) or Msm(1)(x,q) ! D1R --- Derivative of Mcm(1)(x,q) or Msm(1)(x,q) ! F2R --- Mcm(2)(x,q) or Msm(2)(x,q) ! D2R --- Derivative of Mcm(2)(x,q) or Msm(2)(x,q) ! Routines called: ! (1) CVA2 for computing the characteristic values ! (2) FCOEF for computing expansion coefficients ! (3) JYNB for computing Jn(x), Yn(x) and their ! derivatives ! ============================================================== ! implicit none real(wp) a , bj1 , bj2 , by1 , by2 , c1 , c2 , D1r , D2r ,& & dj1 , dj2 , dy1 , dy2 , eps , F1r , F2r , & & fg , q , qm real(wp) u1 , u2 , w1 , w2 , x integer ic , k , Kc , kd , Kf , km , m , nm dimension fg(251) , bj1(0:251) , dj1(0:251) , bj2(0:251) , & & dj2(0:251) , by1(0:251) , dy1(0:251) , by2(0:251) , & & dy2(0:251) eps = 1.0d-14 if ( Kf==1 .and. m==2*int(m/2) ) kd = 1 if ( Kf==1 .and. m/=2*int(m/2) ) kd = 2 if ( Kf==2 .and. m/=2*int(m/2) ) kd = 3 if ( Kf==2 .and. m==2*int(m/2) ) kd = 4 call cva2(kd,m,q,a) if ( q<=1.0_wp ) then qm = 7.5 + 56.1*sqrt(q) - 134.7*q + 90.7*sqrt(q)*q else qm = 17.0 + 3.1*sqrt(q) - .126*q + .0037*sqrt(q)*q endif km = int(qm+0.5*m) if ( km>=251 ) then F1r = dnan() D1r = dnan() F2r = dnan() D2r = dnan() return endif call fcoef(kd,m,q,a,fg) ic = int(m/2) + 1 if ( kd==4 ) ic = m/2 c1 = exp(-x) c2 = exp(x) u1 = sqrt(q)*c1 u2 = sqrt(q)*c2 call jynb(km+1,u1,nm,bj1,dj1,by1,dy1) call jynb(km+1,u2,nm,bj2,dj2,by2,dy2) w1 = 0.0_wp w2 = 0.0_wp if ( Kc/=2 ) then F1r = 0.0_wp do k = 1 , km if ( kd==1 ) then F1r = F1r + (-1)**(ic+k)*fg(k)*bj1(k-1)*bj2(k-1) elseif ( kd==2 .or. kd==3 ) then F1r = F1r + (-1)**(ic+k)*fg(k) & & *(bj1(k-1)*bj2(k)+(-1)**kd*bj1(k)*bj2(k-1)) else F1r = F1r + (-1)**(ic+k)*fg(k) & & *(bj1(k-1)*bj2(k+1)-bj1(k+1)*bj2(k-1)) endif if ( k>=5 .and. abs(F1r-w1)<abs(F1r)*eps ) exit w1 = F1r enddo F1r = F1r/fg(1) D1r = 0.0_wp do k = 1 , km if ( kd==1 ) then D1r = D1r + (-1)**(ic+k)*fg(k) & & *(c2*bj1(k-1)*dj2(k-1)-c1*dj1(k-1)*bj2(k-1)) elseif ( kd==2 .or. kd==3 ) then D1r = D1r + (-1)**(ic+k)*fg(k) & & *(c2*(bj1(k-1)*dj2(k)+(-1)**kd*bj1(k)*dj2(k-1)) & & -c1*(dj1(k-1)*bj2(k)+(-1)**kd*dj1(k)*bj2(k-1))) else D1r = D1r + (-1)**(ic+k)*fg(k) & & *(c2*(bj1(k-1)*dj2(k+1)-bj1(k+1)*dj2(k-1)) & & -c1*(dj1(k-1)*bj2(k+1)-dj1(k+1)*bj2(k-1))) endif if ( k>=5 .and. abs(D1r-w2)<abs(D1r)*eps ) exit w2 = D1r enddo D1r = D1r*sqrt(q)/fg(1) if ( Kc==1 ) return endif F2r = 0.0_wp do k = 1 , km if ( kd==1 ) then F2r = F2r + (-1)**(ic+k)*fg(k)*bj1(k-1)*by2(k-1) elseif ( kd==2 .or. kd==3 ) then F2r = F2r + (-1)**(ic+k)*fg(k) & & *(bj1(k-1)*by2(k)+(-1)**kd*bj1(k)*by2(k-1)) else F2r = F2r + (-1)**(ic+k)*fg(k) & & *(bj1(k-1)*by2(k+1)-bj1(k+1)*by2(k-1)) endif if ( k>=5 .and. abs(F2r-w1)<abs(F2r)*eps ) exit w1 = F2r enddo F2r = F2r/fg(1) D2r = 0.0_wp do k = 1 , km if ( kd==1 ) then D2r = D2r + (-1)**(ic+k)*fg(k) & & *(c2*bj1(k-1)*dy2(k-1)-c1*dj1(k-1)*by2(k-1)) elseif ( kd==2 .or. kd==3 ) then D2r = D2r + (-1)**(ic+k)*fg(k) & & *(c2*(bj1(k-1)*dy2(k)+(-1)**kd*bj1(k)*dy2(k-1)) & & -c1*(dj1(k-1)*by2(k)+(-1)**kd*dj1(k)*by2(k-1))) else D2r = D2r + (-1)**(ic+k)*fg(k) & & *(c2*(bj1(k-1)*dy2(k+1)-bj1(k+1)*dy2(k-1)) & & -c1*(dj1(k-1)*by2(k+1)-dj1(k+1)*by2(k-1))) endif if ( k>=5 .and. abs(D2r-w2)<abs(D2r)*eps ) exit w2 = D2r enddo D2r = D2r*sqrt(q)/fg(1) end subroutine cik01(z,Cbi0,Cdi0,Cbi1,Cdi1,Cbk0,Cdk0,Cbk1,Cdk1) ! ! ========================================================== ! Purpose: Compute modified Bessel functions I0(z), I1(z), ! K0(z), K1(z), and their derivatives for a ! complex argument ! Input : z --- Complex argument ! Output: CBI0 --- I0(z) ! CDI0 --- I0'(z) ! CBI1 --- I1(z) ! CDI1 --- I1'(z) ! CBK0 --- K0(z) ! CDK0 --- K0'(z) ! CBK1 --- K1(z) ! CDK1 --- K1'(z) ! ========================================================== ! implicit none real(wp) a , a0 , a1 , b , w0 complex(wp) ca , cb , Cbi0 , Cbi1 , Cbk0 , Cbk1 , Cdi0 , Cdi1 , & & Cdk0 , Cdk1 , ci , cr , cs , ct , cw , z , z1 , z2 , & & zr , zr2 integer k , k0 dimension a(12) , b(12) , a1(10) ci = (0.0_wp,1.0_wp) a0 = abs(z) z2 = z*z z1 = z if ( a0==0.0_wp ) then Cbi0 = (1.0_wp,0.0_wp) Cbi1 = (0.0_wp,0.0_wp) Cdi0 = (0.0_wp,0.0_wp) Cdi1 = (0.5_wp,0.0_wp) Cbk0 = (1.0e+300_wp,0.0_wp) Cbk1 = (1.0e+300_wp,0.0_wp) Cdk0 = -(1.0e+300_wp,0.0_wp) Cdk1 = -(1.0e+300_wp,0.0_wp) return endif if ( real(z,wp)<0.0 ) z1 = -z if ( a0<=18.0 ) then Cbi0 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25d0*cr*z2/(k*k) Cbi0 = Cbi0 + cr if ( abs(cr/Cbi0)<1.0d-15 ) exit enddo Cbi1 = (1.0_wp,0.0_wp) cr = (1.0_wp,0.0_wp) do k = 1 , 50 cr = 0.25d0*cr*z2/(k*(k+1)) Cbi1 = Cbi1 + cr if ( abs(cr/Cbi1)<1.0d-15 ) exit enddo Cbi1 = 0.5_wp*z1*Cbi1 else data a/0.125d0 , 7.03125d-2 , 7.32421875d-2 , & & 1.1215209960938d-1 , 2.2710800170898d-1 , & & 5.7250142097473d-1 , 1.7277275025845d0 , & & 6.0740420012735d0 , 2.4380529699556d01 , & & 1.1001714026925d02 , 5.5133589612202d02 , & & 3.0380905109224d03/ data b/ - 0.375d0 , -1.171875d-1 , -1.025390625d-1 , & & -1.4419555664063d-1 , -2.7757644653320d-1 , & & -6.7659258842468d-1 , -1.9935317337513d0 , & & -6.8839142681099d0 , -2.7248827311269d01 , & & -1.2159789187654d02 , -6.0384407670507d02 , & & -3.3022722944809d03/ k0 = 12 if ( a0>=35.0 ) k0 = 9 if ( a0>=50.0 ) k0 = 7 ca = exp(z1)/sqrt(2.0_wp*pi*z1) Cbi0 = (1.0_wp,0.0_wp) zr = 1.0_wp/z1 do k = 1 , k0 Cbi0 = Cbi0 + a(k)*zr**k enddo Cbi0 = ca*Cbi0 Cbi1 = (1.0_wp,0.0_wp) do k = 1 , k0 Cbi1 = Cbi1 + b(k)*zr**k enddo Cbi1 = ca*Cbi1 endif if ( a0<=9.0 ) then cs = (0.0_wp,0.0_wp) ct = -log(0.5_wp*z1) - 0.5772156649015329d0 w0 = 0.0_wp cr = (1.0_wp,0.0_wp) do k = 1 , 50 w0 = w0 + 1.0_wp/k cr = 0.25d0*cr/(k*k)*z2 cs = cs + cr*(w0+ct) if ( abs((cs-cw)/cs)<1.0d-15 ) exit cw = cs enddo Cbk0 = ct + cs else data a1/0.125d0 , 0.2109375d0 , 1.0986328125d0 , & & 1.1775970458984d01 , 2.1461706161499d02 , & & 5.9511522710323d03 , 2.3347645606175d05 , & & 1.2312234987631d07 , 8.401390346421d08 , & & 7.2031420482627d10/ cb = 0.5_wp/z1 zr2 = 1.0_wp/z2 Cbk0 = (1.0_wp,0.0_wp) do k = 1 , 10 Cbk0 = Cbk0 + a1(k)*zr2**k enddo Cbk0 = cb*Cbk0/Cbi0 endif Cbk1 = (1.0_wp/z1-Cbi1*Cbk0)/Cbi0 if ( real(z,wp)<0.0 ) then if ( aimag(z)<0.0 ) Cbk0 = Cbk0 + ci*pi*Cbi0 if ( aimag(z)>0.0 ) Cbk0 = Cbk0 - ci*pi*Cbi0 if ( aimag(z)<0.0 ) Cbk1 = -Cbk1 + ci*pi*Cbi1 if ( aimag(z)>0.0 ) Cbk1 = -Cbk1 - ci*pi*Cbi1 Cbi1 = -Cbi1 endif Cdi0 = Cbi1 Cdi1 = Cbi0 - 1.0_wp/z*Cbi1 Cdk0 = -Cbk1 Cdk1 = -Cbk0 - 1.0_wp/z*Cbk1 end subroutine cpsi(x,y,Psr,Psi) ! ! ============================================= ! Purpose: Compute the psi function for a ! complex argument ! Input : x --- Real part of z ! y --- Imaginary part of z ! Output: PSR --- Real part of psi(z) ! PSI --- Imaginary part of psi(z) ! ============================================= ! implicit none real(wp) a , ct2 , Psi , Psr , ri , rr , th , tm , & & tn , x , x0 , x1 , y , y1 , z0 , z2 integer k , n dimension a(8) data a/ - .8333333333333d-01 , .83333333333333333d-02 , & & -.39682539682539683d-02 , .41666666666666667d-02 , & & -.75757575757575758d-02 , .21092796092796093d-01 , & & -.83333333333333333d-01 , .4432598039215686d0/ if ( y==0.0_wp .and. x==int(x) .and. x<=0.0_wp ) then Psr = 1.0e+300_wp Psi = 0.0_wp else x1 = x y1 = y if ( x<0.0_wp ) then x = -x y = -y endif x0 = x n = 0 if ( x<8.0_wp ) then n = 8 - int(x) x0 = x + n endif th = 0.0_wp if ( x0==0.0_wp .and. y/=0.0_wp ) th = halfpi if ( x0/=0.0_wp ) th = atan(y/x0) z2 = x0*x0 + y*y z0 = sqrt(z2) Psr = log(z0) - 0.5_wp*x0/z2 Psi = th + 0.5_wp*y/z2 do k = 1 , 8 Psr = Psr + a(k)*z2**(-k)*cos(2.0_wp*k*th) Psi = Psi - a(k)*z2**(-k)*sin(2.0_wp*k*th) enddo if ( x<8.0_wp ) then rr = 0.0_wp ri = 0.0_wp do k = 1 , n rr = rr + (x0-k)/((x0-k)**2.0_wp+y*y) ri = ri + y/((x0-k)**2.0_wp+y*y) enddo Psr = Psr - rr Psi = Psi + ri endif if ( x1<0.0_wp ) then tn = tan(pi*x) tm = tanh(pi*y) ct2 = tn*tn + tm*tm Psr = Psr + x/(x*x+y*y) + pi*(tn-tn*tm*tm)/ct2 Psi = Psi - y/(x*x+y*y) - pi*tm*(1.0_wp+tn*tn)/ct2 x = x1 y = y1 endif endif end subroutine sphy(n,x,Nm,Sy,Dy) ! ! ====================================================== ! Purpose: Compute spherical Bessel functions yn(x) and ! their derivatives ! Input : x --- Argument of yn(x) ( x ≥ 0 ) ! n --- Order of yn(x) ( n = 0,1,… ) ! Output: SY(n) --- yn(x) ! DY(n) --- yn'(x) ! NM --- Highest order computed ! ====================================================== ! implicit none real(wp) Dy , f , f0 , f1 , Sy , x integer k , n , Nm dimension Sy(0:n) , Dy(0:n) Nm = n if ( x<1.0d-60 ) then do k = 0 , n Sy(k) = -1.0e+300_wp Dy(k) = 1.0e+300_wp enddo return endif Sy(0) = -cos(x)/x f0 = Sy(0) Dy(0) = (sin(x)+cos(x)/x)/x if ( n<1 ) return Sy(1) = (Sy(0)-sin(x))/x f1 = Sy(1) do k = 2 , n f = (2.0_wp*k-1.0_wp)*f1/x - f0 Sy(k) = f if ( abs(f)>=1.0e+300_wp ) exit f0 = f1 f1 = f enddo Nm = k - 1 do k = 1 , Nm Dy(k) = Sy(k-1) - (k+1.0_wp)*Sy(k)/x enddo end subroutine jelp(u,Hk,Esn,Ecn,Edn,Eph) ! ! ======================================================== ! Purpose: Compute Jacobian elliptic functions sn u, cn u ! and dn u ! Input : u --- Argument of Jacobian elliptic functions ! Hk --- Modulus k ( 0 ≤ k ≤ 1 ) ! Output : ESN --- sn u ! ECN --- cn u ! EDN --- dn u ! EPH --- phi ( in degrees ) ! ======================================================== ! implicit none real(wp) a , a0 , b , b0 , c , d , dn , Ecn , Edn , Eph , & & Esn , Hk , r , sa , t , u integer j , n dimension r(40) a0 = 1.0_wp b0 = sqrt(1.0_wp-Hk*Hk) do n = 1 , 40 a = (a0+b0)/2.0_wp b = sqrt(a0*b0) c = (a0-b0)/2.0_wp r(n) = c/a if ( c<1.0d-7 ) exit a0 = a b0 = b enddo dn = 2.0_wp**n*a*u d = 0.0_wp do j = n , 1 , -1 t = r(j)*sin(dn) sa = atan(t/sqrt(abs(1.0_wp-t*t))) d = .5d0*(dn+sa) dn = d enddo Eph = d*180.0d0/pi Esn = sin(d) Ecn = cos(d) Edn = sqrt(1.0_wp-Hk*Hk*Esn*Esn) end end module specfun_module